saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First pass at adding key files

Browse Source
This commit is contained in:
dsainty
2024-06-17 21:49:12 +10:00
commit aa25e9347f
1274 changed files with 392549 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

417
site/glist/lib/GT/Template/Editor.pm Normal file
View File

@@ -0,0 +1,417 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Template::Editor
# Author: Alex Krohn
# CVS Info :
# $Id: Editor.pm,v 2.19 2004/10/19 23:34:44 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# A module for editing templates via an HTML browser.
#
package GT::Template::Editor;
# ===============================================================
use strict;
use GT::Base;
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS);
@ISA = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 2.19 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0;
$ATTRIBS = {
cgi => undef,
root => undef,
backup => undef,
default_dir => '',
default_file => '',
date_format => '',
class => undef,
skip_dir => undef,
skip_file => undef,
select_dir => 'tpl_dir',
demo => undef
};
$ERRORS = {
CANTOVERWRITE => "Unable to overwrite file: %s (Permission Denied). Please set permissions properly and save again.",
CANTCREATE => "Unable to create new files in directory %s. Please set permissions properly and save again.",
CANTMOVE => "Unable to move file %s to %s: %s",
CANTMOVE => "Unable to copy file %s to %s: %s",
FILECOPY => "File::Copy is required in order to make backups.",
};
sub process {
# ------------------------------------------------------------------
# Loads the template editor.
#
my $self = shift;
my $sel_tpl_dir = $self->{select_dir};
my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default';
my $selected_file = $self->{cgi}->param('tpl_file') || '';
my $tpl_text = '';
my $error_msg = '';
my $success_msg = '';
my ($local, $restore) = (0, 0);
# Check the template directory and file
if ($selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..') {
$error_msg = "Invalid template directory $selected_dir";
$selected_dir = '';
$selected_file = '';
}
if ($selected_file =~ m[[\\/\x00-\x1f]]) {
$error_msg = "Invalid template $selected_file";
$selected_dir = '';
$selected_file = '';
}
# Create the local directory if it doesn't exist.
my $tpl_dir = $self->{root} . '/' . $selected_dir;
my $local_dir = $tpl_dir . "/local";
if ($selected_dir and ! -d $local_dir) {
mkdir($local_dir, 0777) or return $self->error('MKDIR', 'FATAL', $local_dir, "$!");
chmod(0777, $local_dir);
}
my $dir = $local_dir;
my $save = $self->{cgi}->param('tpl_name') || $self->{cgi}->param('tpl_file');
# Perform a save if requested.
if ($self->{cgi}->param('saveas') and $save and !$self->{demo}) {
$tpl_text = $self->{cgi}->param('tpl_text');
if (-e "$dir/$save" and ! -w _) {
$error_msg = sprintf($ERRORS->{CANTOVERWRITE}, $save);
}
elsif (! -e _ and ! -w $dir) {
$error_msg = sprintf($ERRORS->{CANTCREATE}, $dir);
}
else {
if ($self->{backup} and -e "$dir/$save") {
$self->copy("$dir/$save", "$dir/$save.bak");
}
local *FILE;
open (FILE, "> $dir/$save") or return $self->error(CANTOPEN => FATAL => "$dir/$save", "$!");
$tpl_text =~ s/\r\n/\n/g;
print FILE $tpl_text;
close FILE;
chmod 0666, "$dir/$save";
$success_msg = "File has been successfully saved.";
$local = 1;
$restore = 1 if -e "$self->{root}/$selected_dir/$save";
$selected_file = $save;
$tpl_text = '';
}
}
# Delete a local template (thereby restoring the system template)
elsif (my $restore = $self->{cgi}->param("restore") and !$self->{demo}) {
if ($self->{backup}) {
if ($self->move("$dir/$restore", "$dir/$restore.bak")) {
$success_msg = "System template '$restore' restored";
}
else {
$error_msg = "Unable to restore system template '$restore': Cannot move '$dir/$restore': $!";
}
}
else {
if (unlink "$dir/$restore") {
$success_msg = "System template '$restore' restored";
}
else {
$error_msg = "Unable to remove $dir/$restore: $!";
}
}
}
# Delete a local template (This is like restore, but happens when there is no system template)
elsif (my $delete = $self->{cgi}->param("delete") and !$self->{demo}) {
if ($self->{backup}) {
if ($self->move("$dir/$delete", "$dir/$delete.bak")) {
$success_msg = "Template '$delete' deleted";
}
else {
$error_msg = "Unable to delete template '$delete': Cannot move '$dir/$delete': $!";
}
}
else {
if (unlink "$dir/$delete") {
$success_msg = "Template '$delete' deleted";
}
else {
$error_msg = "Unable to remove $dir/$delete: $!";
}
}
}
# Load any selected template file.
if ($selected_file and ! $tpl_text) {
if (-f "$dir/$selected_file") {
local (*FILE, $/);
open FILE, "$dir/$selected_file" or die "Unable to open file $dir/$selected_file: $!";
$tpl_text = <FILE>;
close FILE;
$local = 1;
$restore = 1 if -e "$self->{root}/$selected_dir/$selected_file";
}
elsif (-f "$self->{root}/$selected_dir/$selected_file") {
local (*FILE, $/);
open FILE, "$self->{root}/$selected_dir/$selected_file" or die "Unable to open file $self->{root}/$selected_dir/$selected_file: $!";
$tpl_text = <FILE>;
close FILE;
}
else {
$selected_file = '';
}
}
# Load a README if it exists.
my $readme;
if (-e "$dir/README") {
local (*FILE, $/);
open FILE, "$dir/README" or die "unable to open readme: $dir/README ($!)";
$readme = <FILE>;
close FILE;
}
# Set the textarea width and height.
my $editor_rows = $self->{cgi}->param('cookie-editor_rows') || $self->{cgi}->cookie('editor_rows') || 15;
my $editor_cols = $self->{cgi}->param('cookie-editor_cols') || $self->{cgi}->cookie('editor_cols') || 55;
my $file_select = $self->template_file_select;
my $dir_select = $self->template_dir_select;
$tpl_text = $self->{cgi}->html_escape($tpl_text);
my $stats = $selected_file ? $self->template_file_stats($selected_file) : {};
if ($self->{demo} and ($self->{cgi}->param('saveas') or $self->{cgi}->param("delete") or $self->{cgi}->param("restore"))) {
$error_msg = 'This feature has been disabled in the demo!';
}
return {
tpl_name => $selected_file,
tpl_file => $selected_file,
local => $local,
restore => $restore,
tpl_text => \$tpl_text,
error_message => $error_msg,
success_message => $success_msg,
tpl_dir => $selected_dir,
readme => $readme,
editor_rows => $editor_rows,
editor_cols => $editor_cols,
dir_select => $dir_select,
file_select => $file_select,
%$stats
};
}
sub _skip_files {
my ($skip, $file) = @_;
return 1 if $skip->{$file}
or substr($file, 0, 1) eq '.' # skip dotfiles
or substr($file, -4) eq '.bak'; # skip .bak files
foreach my $f (keys %$skip) {
my $match = quotemeta $f;
$match =~ s/\\\*/.*/g;
$match =~ s/\\\?/./g;
return 1 if $file =~ /^$match$/;
}
return;
}
sub template_file_select {
# ------------------------------------------------------------------
# Returns a select list of templates in a given dir.
#
my $self = shift;
my $path = $self->{root};
my %files;
my $sel_tpl_dir = $self->{select_dir};
my $selected_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default';
my $selected_file = $self->{cgi}->param('tpl_file') || $self->{default_file} || 'default';
$selected_file = $self->{cgi}->param('tpl_name') if $self->{cgi}->param('saveas');
my %skip;
if ($self->{skip_file}) {
for (@{$self->{skip_file}}) {
$skip{$_}++;
}
}
else {
$skip{README} = $skip{'language.txt'} = $skip{'globals.txt'} = 1;
}
# Check the template directory
return if $selected_dir =~ m[[\\/\x00-\x1f]] or $selected_dir eq '..';
my $system_dir = $path . "/" . $selected_dir;
my $local_dir = $path . "/" . $selected_dir . '/local';
foreach my $dir ($system_dir, $local_dir) {
opendir (TPL, $dir) or next;
while (defined(my $file = readdir TPL)) {
next unless -f "$dir/$file" and -r _;
next if _skip_files(\%skip, $file);
$files{$file} = 1;
}
closedir TPL;
}
my $f_select_list = '<select name="tpl_file"';
$f_select_list .= qq' class="$self->{class}"' if $self->{class};
$f_select_list .= ">\n";
foreach (sort keys %files) {
my $system = -e $path . '/' . $selected_dir . '/' . $_;
my $local = -e $path . '/' . $selected_dir . '/local/' . $_;
my $changed = $system && $local ? ' *' : $local ? ' +' : '';
$f_select_list .= qq' <option value="$_"';
$f_select_list .= ' selected' if $_ eq $selected_file;
$f_select_list .= ">$_$changed</option>\n";
}
$f_select_list .= "</select>";
return $f_select_list;
}
sub template_dir_select {
# ------------------------------------------------------------------
# Returns a select list of template directories.
#
my $self = shift;
my ($dir, $file, @dirs);
my $name = $self->{select_dir};
my $selected_dir = $self->{cgi}->param($name) || $self->{default_dir} || 'default';
$dir = $self->{root};
my %skip = ('..' => 1, '.' => 1);
if ($self->{skip_dir}) {
for (@{$self->{skip_dir}}) { $skip{$_}++ }
}
else {
$skip{admin} = $skip{help} = $skip{CVS} = 1;
}
opendir (TPL, $dir) or die "unable to open directory: '$dir' ($!)";
while (defined($file = readdir TPL)) {
next if $skip{$file};
next unless (-d "$dir/$file");
push @dirs, $file;
}
closedir TPL;
my $d_select_list = qq'<select name="$name"';
$d_select_list .= qq' class="$self->{class}"' if $self->{class};
$d_select_list .= ">\n";
foreach (sort @dirs) {
$d_select_list .= qq' <option value="$_"';
$d_select_list .= ' selected' if $_ eq $selected_dir;
$d_select_list .= ">$_</option>\n";
}
$d_select_list .= "</select>";
return $d_select_list;
}
sub template_file_stats {
# ------------------------------------------------------------------
# Returns information about a file. Takes the following arguments:
# - filename
# - template set
# The following tags are returned:
# - file_path - the full path to the file, relative to the admin root directory
# - file_size - the size of the file in bytes
# - file_local - 1 or 0 - true if it is a local file
# - file_restore - 1 or 0 - true if it is a local file and a non-local file of the same name exists (The non-local can be restored)
# - file_mod_time - the date the file was last modified
#
require GT::Date;
my ($self, $file) = @_;
my $sel_tpl_dir = $self->{select_dir};
my $tpl_dir = $self->{cgi}->param($sel_tpl_dir) || $self->{default_dir} || 'default';
my $return = { file_local => 1, file_restore => 1 };
my $dir = "$self->{root}/$tpl_dir";
if (-f "$dir/local/$file" and -r _) {
$return->{file_path} = "templates/$tpl_dir/local/$file";
$return->{file_size} = -s _;
$return->{file_local} = 1;
my $mod_time = (stat _)[9];
$return->{file_restore} = (-f "$dir/$file" and -r _) ? 1 : 0;
if ($self->{date_format}) {
require GT::Date;
$return->{file_mod_time} = GT::Date::date_get($mod_time, $self->{date_format});
}
else {
$return->{file_mod_time} = localtime($mod_time);
}
}
else {
$return->{file_path} = "templates/$tpl_dir/$file";
$return->{file_size} = -s "$dir/$file";
$return->{file_local} = 0;
$return->{file_restore} = 0;
my $mod_time = (stat _)[9];
if ($self->{date_format}) {
require GT::Date;
$return->{file_mod_time} = GT::Date::date_get($mod_time, $self->{date_format});
}
else {
$return->{file_mod_time} = localtime($mod_time);
}
}
return $return;
}
sub move {
# -------------------------------------------------------------------
# Uses File::Copy to move a file.
#
my $self = shift;
my ($from, $to) = @_;
eval { require File::Copy; };
if ($@) {
return $self->error('FILECOPY', $@);
}
File::Copy::mv($from, $to) or return $self->error('CANTMOVE', $from, $to, "$!");
}
sub copy {
# -------------------------------------------------------------------
# Uses File::Copy to move a file.
#
my $self = shift;
my ($from, $to) = @_;
eval { require File::Copy; };
if ($@) {
return $self->error('FILECOPY', $@);
}
File::Copy::cp($from, $to) or return $self->error('CANTCOPY', $from, $to, "$!");
}
__END__
=head1 NAME
GT::Template::Editor - This module provides an easy way to edit templates.
=head1 SYNOPSIS
Should be called like:
require GT::Template::Editor;
my $editor = new GT::Template::Editor (
root => $CFG->{admin_root_path} . '/templates',
default_dir => $CFG->{build_default_tpl},
backup => 1,
cgi => $IN
);
return $editor->process;
and it returns a hsah ref of variables used for displaying a template editor page.
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Editor.pm,v 2.19 2004/10/19 23:34:44 jagerman Exp $
=cut

250
site/glist/lib/GT/Template/Inheritance.pm Normal file
View File

@@ -0,0 +1,250 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Template::Inheritance
# Author: Scott Beck
# CVS Info :
# $Id: Inheritance.pm,v 1.7 2005/02/09 20:51:27 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: Provides class methods to deal with template
# inheritance.
#
package GT::Template::Inheritance;
# ==================================================================
use strict;
use vars qw($ERRORS);
use bases 'GT::Base' => '';
use GT::Template;
$ERRORS = { RECURSION => q _Recursive inheritance detected and interrupted: '%s'_ };
sub get_all_paths {
# ----------------------------------------------------------------------------
my ($class, %opts) = @_;
my $file = delete $opts{file};
my $single = delete $opts{_single};
$class->fatal(BADARGS => "No file specified to $class->" . ($single ? 'get_path' : 'get_all_paths')) unless defined $file;
my $root = delete $opts{path};
$class->fatal(BADARGS => "No path specified to $class->" . ($single ? 'get_path' : 'get_all_paths')) unless defined $root;
$class->fatal(BADARGS => "Path $root does not exist or is not a directory") unless -d $root;
my $local = exists $opts{local} ? delete $opts{local} : 1;
my $inheritance = exists $opts{inheritance} ? delete $opts{inheritance} : 1;
# Old no-longer-supported option:
delete @opts{qw/use_inheritance use_local local_inheritance/};
$class->fatal(BADARGS => "Unknown arguments: " . join ", ", keys %opts) if keys %opts;
my @paths = $class->tree(path => $root, local => $local, inheritance => $inheritance);
my @files;
for (@paths) {
if (-f "$_/$file" and -r _) {
return "$_/$file" if $single;
push @files, "$_/$file";
}
}
return if $single;
return @files;
}
sub get_path {
# ----------------------------------------------------------------------------
shift->get_all_paths(@_, _single => 1);
}
sub tree {
# -----------------------------------------------------------------------------
my $class = shift;
my %opts = @_ > 1 ? @_ : (path => shift);
my $root = delete $opts{path};
$class->fatal(BADARGS => "No path specified for $class->tree") unless defined $root;
$class->fatal(BADARGS => "Path '$root' does not exist or is not a directory") unless -d $root;
my $local = exists $opts{local} ? delete $opts{local} : 1;
my $inheritance = exists $opts{inheritance} ? delete $opts{inheritance} : 1;
$class->fatal(BADARGS => "Unknown arguments: " . join ", ", keys %opts) if keys %opts;
my @paths;
push @paths, $root;
my %encountered = ($root => 1);
if ($inheritance) {
for my $path (@paths) {
my $tplinfo = GT::Template->load_tplinfo($path);
next if not defined $tplinfo->{inheritance};
my @inherit = ref $tplinfo->{inheritance} eq 'ARRAY' ? @{$tplinfo->{inheritance}} : $tplinfo->{inheritance};
for (@inherit) {
my $inh = m!^(?:[a-zA-Z]:)?[\\/]! ? $_ : "$path/$_";
if (length $inh > 500 or $encountered{$inh}++) {
return $class->fatal(RECURSION => $inh);
}
push @paths, $inh;
}
}
}
if ($local) {
for (my $i = 0; $i < @paths; $i++) {
if (-d "$paths[$i]/local") {
splice @paths, $i, 0, "$paths[$i]/local";
$i++;
}
}
}
return @paths;
}
1;
__END__
=head1 NAME
GT::Template::Inheritance - Provides GT::Template inheritance/local file
determination.
=head1 SYNOPSIS
use GT::Template::Inheritance;
my $file = GT::Template::Inheritance->get_path(
file => "foo.htm",
path => "/path/to/my/template/set"
);
my @files = GT::Template::Inheritance->get_all_paths(
file => "foo.htm",
path => "/path/to/my/template/set"
);
my @paths = GT::Template::Inheritance->tree(
path => "/path/to/my/template/set"
);
=head1 DESCRIPTION
GT::Template::Inheritance provides an interface to accessing files for
GT::Template template parsing and include handling. It supports following
inheritance directories and respects "local" template directories.
=head2 Inheritance
GT::Template inheritance works by looking for a .tplinfo file in the template
directory (or local/.tplinfo, if it exists). In order for the template
directory to inherit from another template directory, this file must exist and
must evaluate to a hash reference containing an C<inheritance> key. The
following is a possible .tplinfo file contents:
{
inheritance => '../other'
}
The above example would indicate that files in this template set can be
inherited from the ../other path, relative to the current template set
directory. The inheritance directory may also contain a full path.
=head2 Inheriting from multiple locations
You may also inherit from multiple locations by using an array reference for
the inheritance value:
{
inheritance => ['../other', '/full/path/to/a/third']
}
With the above .tplinfo file, files would be checked for in the current path,
then C<../other>, then any of C<../other>'s inherited directories, then in
C<third>, then in any of C<third>'s inherited directories.
Also keep in mind that "local" directories, if they exist, will be checked for
the file before each of their respective directories.
Assuming that the initial template path was C</full/path/one>, and assuming
that C<../other> inherited from C<../other2>, the directories checked would be
as follows:
/full/path/one/local
/full/path/one
/full/path/one/../other/local # i.e. /full/path/other/local
/full/path/one/../other # i.e. /full/path/other
/full/path/one/../other/../other2/local # i.e. /full/path/other2/local
/full/path/one/../other/../other2 # i.e. /full/path/other2
/full/path/to/a/third/local
/full/path/to/a/third
=head1 METHODS
All methods in GT::Template::Inheritance are class methods. Each method takes
a hash of options as an argument.
=head2 get_path
=head2 get_all_paths
These methods are used to obtain the location of the file GT::Template will
use, taking into account all inherited and "local" template directories. The
get_path option will return the path to the file that will be included, while
the get_all_paths option returns the path to B<all> copies of the file found in
the local/inheritance tree. Both methods take a hash containing the following:
=over 4
=item file
The name of the file desired.
=item path
The template directory at which to start looking for the above file. Depending
on the existance of "local" directories and template inheritance, more than
just this directory will be checked for the file.
=item local
Optional. Can be passed with a false value to override the checking of "local"
directories for files.
=item inheritance
Optional. Can be passed with a false value to override the checking of
inheritance directories for files.
=back
=head2 tree
This method returns a list of directories that would be searched for a given
file, in the order they would be searched. It takes the C<path>, C<local>, and
C<inheritance> options above, but not the C<file> option.
=head1 SEE ALSO
L<GT::Template>
=head1 MAINTAINER
Jason Rhinelander
=head1 COPYRIGHT
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Inheritance.pm,v 1.7 2005/02/09 20:51:27 jagerman Exp $
=cut

987
site/glist/lib/GT/Template/Parser.pm Normal file
View File

@@ -0,0 +1,987 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Template::Parser
# Author: Jason Rhinelander
# CVS Info :
# $Id: Parser.pm,v 2.140 2005/07/05 00:33:57 jagerman Exp $
#
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# A module for parsing templates. This module actually generates
# Perl code that will print the template.
#
package GT::Template::Parser;
# ===============================================================
use 5.004_04;
use strict;
use GT::Base;
use GT::Template;
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS %ESCAPE_MAP);
@ISA = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 2.140 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0;
$ATTRIBS = { root => '.', indent => ' ', begin => '<%', end => '%>', print => 0 };
$ERRORS = {
NOTEMPLATE => "No template file was specified.",
BADINC => $GT::Template::ERRORS->{BADINC},
CANTOPEN => "Unable to open template file '%s': %s",
DEEPINC => $GT::Template::ERRORS->{DEEPINC},
EXTRAELSE => "Error: extra else tag",
EXTRAELSIF => "Error: extra elsif/elseif tag",
NOSCALAR => "Error: Variable '%s' is not scalar",
UNMATCHEDELSE => "Error: Unmatched else tag",
UNMATCHEDELSIF => "Error: Unmatched elsif/elseif tag",
UNMATCHEDENDIF => "Error: Unmatched endif/endifnot/endunless tag",
UNMATCHEDENDLOOP => "Error: endloop found outside of loop",
UNMATCHEDNEXTLOOP => "Error: nextloop found outside of loop",
UNMATCHEDLASTLOOP => "Error: lastloop found outside of loop",
UNKNOWNTAG => $GT::Template::ERRORS->{UNKNOWNTAG},
UNKNOWNINCLUDETAG => "Unknown tag in include: '%s'"
};
use vars qw/%FILTERS $RE_FILTERS $RE_SET $RE_MATH $RE_EXPR/;
%FILTERS = (
escape_html => '$tmp = GT::CGI::html_escape($tmp);',
unescape_html => '$tmp = GT::CGI::html_unescape($tmp);',
escape_url => '$tmp = GT::CGI::escape($tmp);',
unescape_url => '$tmp = GT::CGI::unescape($tmp);',
escape_js => q{$tmp =~ s{([\\\/'"])}{\\\$1}g; $tmp =~ s{(?:\r\n|\r|\n)}{\\\n}g;},
nbsp => '$tmp =~ s/\s/&nbsp;/g;'
);
@FILTERS{qw/escapeHTML unescapeHTML escapeURL unescapeURL escapeJS/} = @FILTERS{qw/escape_html unescape_html escape_url unescape_url escape_js/};
for (qw/uc lc ucfirst lcfirst/) {
$FILTERS{$_} = '$tmp = ' . $_ . '($tmp);';
}
$RE_FILTERS = '(?:(?:' . join('|', map quotemeta, keys %FILTERS) . ')\b\s*)+';
$RE_SET = q(set\s+(\w+(?:\.\$?\w+)*)\s*([-+*/%^.]|\bx|\|\||&&)?=\s*); # Two captures - the variable and the (optional) assignment modifier
$RE_EXPR = qq{($RE_FILTERS)?('(?:[^\\\\']|\\\\.)*'|"(?:[^\\\\"]|\\\\.)*"|(?!$RE_FILTERS)[^\\s('"]+)}; # Two captures - the (optional) filters, and the value/variable
$RE_MATH = q(\bx\b|/\d+(?=\s)|\bi/|[+*%~^/-]|\|\||&&);
sub parse {
# ---------------------------------------------------------------
# Can be called as either a class method or object method. This
# returns three things - the first is a scalar reference to a string
# containing all the perl code, the second is an array reference
# of dependencies, and the third is the filetype of the template -
# matching this regular expression: /^((INH:)*(REL|LOCAL)|STRING)$/.
# For example, 'INH:INH:INH:INH:LOCAL', 'LOCAL', 'INH:REL', 'REL', or 'STRING'
#
my $self = ref $_[0] ? shift : (shift->new);
my ($template, $opt, $print) = @_; # The third argument should only be used internally.
defined $template or return $self->fatal(NOTEMPLATE => $template);
defined $opt or $opt = {};
# Set print to 1 if we were called via parse_print.
$opt->{print} = 1 if $print;
# Load the template which can either be a filename, or a string passed in.
$self->{root} = $opt->{root} if $opt->{root};
my ($full, $string);
my $type = '';
if (exists $opt->{string}) {
$full = $template;
$string = $opt->{string};
$type = "STRING";
}
else {
require GT::Template::Inheritance;
$full = GT::Template::Inheritance->get_path(path => $self->{root}, file => $template)
or return $self->fatal(CANTOPEN => $template, "File does not exist.");
}
my ($mtime, $size, $tpl) = (0, 0);
if (defined $string) {
$tpl = \$string;
}
else {
($mtime, $size, $tpl) = $self->load_template($full);
}
# Parse the template.
$self->debug("Parsing '$template' (found '$full') with (print => $opt->{print})") if $self->{_debug};
my @files = ([$template, $full, $mtime, $size]);
my $code = $self->_parse($template, $opt, $tpl, \@files);
# Return the code, and an array reference of [filename, path, mtime, size] items
return ($code, \@files);
}
sub parse_print {
# ---------------------------------------------------------------
# Print output as template is parsed.
#
my $self = shift;
$self->parse(@_[0..1], 1)
}
sub load_template {
# ---------------------------------------------------------------
# Loads either a given filename, or a template string, and returns a reference to it.
#
my ($self, $full_file) = @_;
$self->debug("Reading '$full_file'") if $self->{_debug};
-e $full_file or return $self->fatal(CANTOPEN => $full_file, "File does not exist.");
local *TPL;
open TPL, "< $full_file" or return $self->fatal(CANTOPEN => $full_file, "$!");
my ($mtime, $size) = (stat TPL)[9, 7];
my $ret = \do { local $/; <TPL> };
close TPL;
return $mtime, $size, $ret;
}
sub _parse {
# ---------------------------------------------------------------
# Parses a template.
#
my ($self, $template, $opt, $tpl, $files) = @_;
local $self->{opt} = {};
$self->{opt}->{print} = exists $opt->{print} ? $opt->{print} : $self->{print};
$self->{opt}->{indent} = exists $opt->{indent} ? $opt->{indent} : $self->{indent};
unless (defined $opt->{string}) {
# Set the root if this is a full path so includes can be relative to template.
if ((not $self->{root} or $self->{root} eq '.') and ((index($template, '/') == 0) or (index($template, ':') == 1))) {
$self->{root} = substr($template, 0, rindex($template, '/'));
substr($template, 0, rindex($template, '/') + 1) = '';
}
}
return $self->_parse_tags($tpl, $files);
}
sub _text_escape {
my $text = shift;
$text =~ s/(\\(?=[{}\\]|$)|[{}])/\\$1/g;
$text;
}
sub _filter {
my ($filter, $var) = @_;
my $f = $FILTERS{$filter};
$f =~ s/\$tmp\b/$var/g if $var;
$f . " # $filter";
}
sub _comment {
my $comment = shift;
$comment =~ s/^/#/gm;
$comment . "\n";
}
sub _parse_tags {
# ---------------------------------------------------------------
# Returns a string containing perl code that, when run (the code should be
# passed a template object as its argument) will produce the template.
# Specifically, the returned from this is a scalar reference (containing the
# perl code) and an array reference of the file's dependencies.
#
my ($self, $tplref, $files) = @_;
my $tpl = $$tplref;
my $begin = quotemeta($self->{begin});
my $end = quotemeta($self->{end});
my $root = $self->{root};
my $loop_depth = 0;
my $i = -1;
my @seen_else = ();
my @if_level = ();
my $print = $self->{opt}->{print};
my $indent = $self->{opt}->{indent};
my $indent_level = 0; # The file is already going to be in a hash
my %deps;
my $last_pos = 0;
# Can only go up to GT::Template::INCLUDE_LIMIT includes inside includes.
my $include_safety = 0;
# Store the "if" depth so that too many or too few <%endif%>'s in an include
# won't break things:
my @include_ifdepth;
my $return = <<'CODE';
local $^W; # Get rid of warnings. unfortunately, this won't work for Perl 5.6's -W switch
my $self = shift;
my $return = '';
my $tags = $self->vars;
my $escape = $self->{opt}->{escape};
my $strict = $self->{opt}->{strict};
my ($tmp, $tmp2, $tmp3);
CODE
# We loop through the text looking for <% and %> tags, but also watching out for comments
# <%-- some comment --%> as they can contain other tags.
my $text = sub {
my $text = shift;
length $text or return;
$return .= ($indent x ($indent_level)) . ($print ? q|print q{| : q|$return .= q{|);
$return .= _text_escape($text) . q|};
|; };
# $1 $2
while ($tpl =~ /(\s*$begin\s*~\s*$end\s*|(?:\s*$begin\s*~|$begin)\s*(--.*?(?:--(?=\s*(?:~\s*)?$end)|$)|.+?)\s*(?:~\s*$end\s*|$end|$))/gs) {
my $tag = $2;
my $tag_len = length $1;
my $print_start = $last_pos;
$last_pos = pos $tpl;
# Print out the text before the tag.
$text->(substr($tpl, $print_start, $last_pos - $tag_len - $print_start));
next unless defined $tag; # Won't be defined for: <%~%>, which is a special cased no-op, whitespace reduction tag
# Handle nested comments
if (substr($tag,0,2) eq '--') {
my $save_pos = pos($tag);
while ($tag =~ /\G.*?$begin\s*(?:~\s*)?--/gs) {
$save_pos = pos($tag);
my $tpl_save_pos = pos($tpl);
if ($tpl =~ /\G(.*?--\s*(?:~\s*$end\s*|$end))/gs) {
$tag .= $1;
pos($tag) = $save_pos;
$last_pos = pos($tpl);
}
else {
$last_pos = pos($tpl) = length($tpl);
$tag .= substr($tpl, $last_pos);
last;
}
}
}
# Tag consists of only \w's and .'s - it's either a variable or some sort of
# keyword (else, endif, etc.)
elsif ($tag !~ /[^\w.]/) {
# 'else' - If $i is already at -1, we have an umatched tag.
if ($tag eq 'else') {
if ($i == -1 or $indent_level != $if_level[$i]) {
$return .= _comment($ERRORS->{UNMATCHEDELSE});
$text->($ERRORS->{UNMATCHEDELSE});
}
elsif ($seen_else[$i]++) {
$return .= _comment($ERRORS->{EXTRAELSE});
$text->($ERRORS->{EXTRAELSE});
}
else {
$return .= $indent x ($indent_level - 1) . q|}
|; $return .= $indent x ($indent_level - 1) . q|else {
|; }
}
# 'endif', 'endunless', 'endifnot' - decrement our level. If $i is already at -1, we have an umatched tag.
elsif ($tag eq 'endif' or $tag eq 'endifnot' or $tag eq 'endunless') {
if ($i == -1 or @include_ifdepth and $i <= $include_ifdepth[-1][0] or $indent_level != $if_level[$i]) {
$return .= _comment($ERRORS->{UNMATCHEDENDIF});
$text->($ERRORS->{UNMATCHEDENDIF});
}
else {
--$i; --$#seen_else; --$#if_level; # for vim: {
$return .= $indent x --$indent_level . q|}
|; }
}
# 'endloop' - ends a loop
elsif ($tag eq 'endloop') {
if ($loop_depth <= 0) {
$return .= _comment($ERRORS->{UNMATCHEDENDLOOP});
$text->($ERRORS->{UNMATCHEDENDLOOP});
}
else {
$loop_depth--; # for vim: {{{{
$return .= $indent x --$indent_level . q|}
|; $return .= $indent x --$indent_level . q|}
|; $return .= $indent x --$indent_level . q|}
|; $return .= $indent x $indent_level . q|for (keys %loop_set) { $self->{VARS}->{$_} = $orig->{$_} }
|; $return .= $indent x --$indent_level . q|}
|; }
}
# 'lastloop' - simply put in a last;
elsif ($tag eq 'lastloop') {
if ($loop_depth <= 0) {
$return .= _comment($ERRORS->{UNMATCHEDLASTLOOP});
$text->($ERRORS->{UNMATCHEDLASTLOOP});
}
else {
$return .= $indent x $indent_level . q|last LOOP| . $loop_depth . q|;
|; }
}
# 'nextloop' - simply put in a next;
elsif ($tag eq 'nextloop') {
if ($loop_depth <= 0) {
$return .= _comment($ERRORS->{UNMATCHEDNEXTLOOP});
$text->($ERRORS->{UNMATCHEDNEXTLOOP});
}
else {
$return .= $indent x $indent_level . q|next;
|; }
}
# 'endparse' - stops the parser.
elsif ($tag eq 'endparse') {
$return .= $indent x $indent_level . q|return | . ($print ? q|1| : q|\$return|) . q|;
|; }
# 'endinclude' - this is put at the end of an include when the include is inserted into the current template data.
elsif ($tag eq 'endinclude') {
if (@include_ifdepth) {
while ($indent_level > $include_ifdepth[-1][1]) { # for vim: {
$return .= ($indent x --$indent_level) . q|}
|; }
$i = $include_ifdepth[-1][0];
}
$include_safety--;
pop @include_ifdepth; # for vim: {
$return .= $indent x --$indent_level . q|} # Done include
|; }
elsif ($tag eq 'DUMP') {
my $func = $self->_check_func('GT::Template::dump(-auto => 1)');
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|; }
# Function call (without spaces)
elsif (my $func = $self->_check_func($tag)) {
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|; }
# Variable
else {
$return .= $indent x $indent_level;
$return .= ($print ? q|print| : q|$return .=|) . q| $tmp if defined($tmp = $self->_get_var(q{| . _text_escape($tag) . q|}, $escape, $strict));
|; }
}
# 'if', 'ifnot', 'unless', 'elsif', 'elseif'
elsif ($tag =~ s/^(if(?:not)?|unless|else?if)\b\s*//) {
my $op = $1;
$op = "unless" if $op eq "ifnot";
$op = "elsif" if $op eq "elseif";
if ($op eq 'elsif') {
if ($i == -1 or $indent_level != $if_level[$i]) {
$return .= _comment($ERRORS->{UNMATCHEDELSIF});
$text->($ERRORS->{UNMATCHEDELSIF});
next;
}
elsif ($seen_else[$i]) {
$return .= _comment($ERRORS->{EXTRAELSIF});
$text->($ERRORS->{EXTRAELSIF});
next;
}
# for vim: {
$return .= $indent x ($indent_level - 1) . q|}
|; $return .= $indent x ($indent_level - 1) . q|elsif (|;
}
else {
$seen_else[++$i] = 0;
$return .= $indent x $indent_level++;
$return .= "$op (";
$if_level[$i] = $indent_level;
}
my @tests;
my $bool = '';
if ($tag =~ /\sor\s*(?:not)?\s/i) {
@tests = grep $_, split /\s+or\s*(not)?\s+/i, $tag;
$bool = ' or ';
}
elsif ($tag =~ /\sand\s*(?:not)?\s/i) {
@tests = grep $_, split /\s+and\s*(not)?\s+/i, $tag;
$bool = ' and ';
}
else {
@tests = $tag;
}
if ($tests[0] =~ s/^not\s+//) {
unshift @tests, "not";
}
my @all_tests;
my $one_neg;
for my $tag (@tests) {
if ($tag eq 'not') {
$one_neg = 1;
next;
}
my $this_neg = $one_neg ? $one_neg-- : 0;
$tag =~ s/^\$?([\w:.\$-]+)\b\s*// or next;
my $var = $1;
if (index($var, '::') > 0) {
$var = $self->_check_func($var);
}
else {
$var = q|$self->_get_var(q{| . _text_escape($var) . q|}, 0, 0)|;
}
my ($comp, $casei, $val);
if (length($tag)) {
if ($tag =~ s/^(==?|!=|>=?|<=?|%|(i?)(?:eq|ne|g[et]|l[et]))\s*//) { $casei = $2 ? 1 : 0; $comp = " " . ($casei ? substr($1, 1) : $1) . " " }
elsif ($tag =~ s/^(i?)(?:like|contains)\s+//i) { $casei = $1 ? 1 : 0; $comp = "contains" }
elsif ($tag =~ s/^(i?)(start|end)s?\s+//i) { $casei = $1 ? 1 : 0; $comp = $2 }
$val = $tag if defined $comp;
}
$comp = ' == ' if $comp and $comp eq ' = ';
my $full_comp = defined($comp);
my $result = $this_neg ? 'not(' : '';
if ($full_comp) {
if (substr($val,0,1) eq '$') {
substr($val,0,1) = '';
$val = q|$self->_get_var(q{| . _text_escape($val) . q|}, 0, 0)|;
}
elsif ($val =~ /^['"]/) {
$val = _quoted_string($val);
}
elsif (index($val, '::') > 0) {
$val = $self->_check_func($val);
}
elsif ($val !~ /^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?$/) {
$val = "q{" . _text_escape($val) . "}";
}
if ($casei) {
$val = "lc($val)";
$var = "lc($var)";
}
if ($comp eq 'contains') {
$result .= qq|index($var, $val) >= 0|;
}
elsif ($comp eq 'start') {
$result .= qq|substr($var, 0, length $val) eq $val|;
}
elsif ($comp eq 'end') {
$result .= qq|substr($var, -length $val) eq $val|;
}
elsif ($comp) {
$result .= qq|$var $comp $val|;
}
}
else { # Just a simple <%if var%> (Or something we don't understand, in which case we'll treat it like a simple <%if var%>)
$result .= $var;
}
$result .= ")" if $this_neg;
push @all_tests, $result;
}
my $final_result = join $bool, @all_tests;
$return .= $final_result;
$return .= q|) {
|; # for vim: }
}
# 'loop' - <%loop var%>, <%loop Pkg::Func(arg, $arg => arg)%>, <%loop var(arg, $arg => arg)%>, <%loop 1 .. $end%>
elsif ($tag =~ /^loop\s+(.+)/s) {
$loop_depth++;
my $loopon = $1;
$return .= $self->_loop_on($loopon, $indent, $indent_level, $loop_depth);
}
# 'include $foo' - runtime includes based on variable value.
elsif ($tag =~ /^include\s*\$(.*)/) {
my $include_var = $1;
$return .= $indent x $indent_level++;
$return .= q|if (defined($tmp = $self->_get_var(q{| . _text_escape($include_var) . q|}, $escape))) {
|; $return .= $indent x $indent_level . ($print ? 'print ' : '$return .= ');
$return .= q|$self->_include(ref $tmp eq 'SCALAR' ? $$tmp : $escape ? GT::CGI::html_escape($tmp) : $tmp);
|; $return .= $indent x ($indent_level - 1) . q|}
|; $return .= $indent x ($indent_level - 1) . q|else {
|; $return .= $indent x $indent_level; # for vim: }
$return .= ($print ? q|print q{| : q|$return .= q{|) . _text_escape(sprintf($ERRORS->{UNKNOWNINCLUDETAG}, $include_var)) . q|};
|; $return .= $indent x --$indent_level . q|}
|; }
# 'include' - load the file into the current template and continue parsing.
# The template must be added to this template's dependancy list.
# 'include $foo' is handled completely differently, above.
elsif ($tag =~ /^include\b\s*([^\$].*)/) {
my $include = $1;
# If inside an if, but not a loop, turn this into a runtime include, so that:
# <%if foo%><%include bar.html%><%endif%>
# is faster -- at least when foo is not set. Compile-time includes are still
# faster (as long as they are actually used) - but not by a significant amount
# unless inside a largish loop.
if (!$loop_depth and $i > -1 and not ($include eq '.' or $include eq '..' or $include =~ m{[/\\]})) {
$return .= $indent x $indent_level;
$return .= ($print ? 'print' : '$return .=') . q| $self->_include(q{| . _text_escape($include) . q|}, 1);
|; next;
}
my $filename;
if ($include =~ m{^(?:\w:)?[/\\]}) {
$filename = $include;
}
else {
require GT::Template::Inheritance;
$filename = GT::Template::Inheritance->get_path(path => $root, file => $include);
}
local *INCL;
if ($filename and open INCL, "<$filename") {
push @$files, [$include, $filename, (stat INCL)[9, 7]]; # mtime, size
my $data = do { local $/; <INCL> };
close INCL;
substr($tpl, $last_pos - $tag_len, $tag_len) = $data . "$self->{begin}endinclude$self->{end}";
$last_pos -= $tag_len;
pos($tpl) = $last_pos;
++$include_safety <= GT::Template::INCLUDE_LIMIT or return $self->fatal('DEEPINC');
$return .= $indent x $indent_level++ . q|{; | # The ; allows empty include files. for vim: }
. _comment("Including $filename");
push @include_ifdepth, [$i, $indent_level];
}
else {
push @$files, [$include, $filename, -1, -1];
my $errfile = $filename || "$root/$include";
$return .= _comment(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
$text->(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
}
next;
}
# 'set' - set a value from the templates, optionally with a modifier (i.e. set
# foo = 4 vs. set foo += 4), also look for things like <%... x ...%>, <%... ~
# ...%>, etc., optionally with a 'set' on the front. Filters are permitted as
# well.
#
# $1-3 $4, $5 $6 $7, $8 $9 $10 $11
elsif ($tag =~ m{^(?:($RE_SET)(?:$RE_EXPR\s*($RE_MATH))?|$RE_EXPR\s*($RE_MATH))\s*($RE_FILTERS)?(.+)}os) {
# $set is set if this is a 'set' (set foo = 3) as opposed to merely a modifier (foo + 3)
# $setvar is the variable to set (obviously only if $set is set)
# $change is set if this is a modifier assignment (i.e. 'set foo += 3' as opposed to 'set foo = 3')
# $var is the value to set in a multi-value expression - i.e. bar in 'set foo = bar + 3', but undefined in 'set foo = $bar'
# or 'set foo = 3' - it can be a variable (i.e. without a $) or quoted string.
# $var_filters are any filters that apply to $var, such as the 'escape_html' in 'set foo = escape_html $bar x 5'
# $comp is the modifer to the value - such as the 'x' in 'set foo = $bar x 3'
# $val is the actual value to set, and is the only parameter common to all cases handled here. It can be a $variable,
# quoted string, or bareword string.
# $val_filters are any filters to apply to $val
my ($set, $setvar, $change, $var_filters, $var, $comp);
my ($val_filters, $val) = ($10, $11);
if ($1) {
($set, $setvar, $change, $var_filters, $var, $comp) = ($1, $2, $3 || '', $4, $5, $6);
}
else {
($var_filters, $var, $comp) = ($7, $8, $9);
}
if (defined $var) {
if ($var =~ /^['"]/) {
$var = _quoted_string($var);
}
else {
substr($var,0,1) = '' if substr($var,0,1) eq '$';
$var = q|$self->_get_var(q{| . _text_escape($var) . q|})|;
}
if ($var_filters) {
$return .= $indent x $indent_level;
$return .= "\$tmp2 = $var;\n";
$var = '$tmp2';
for (reverse split ' ', $var_filters) {
$return .= $indent x $indent_level;
$return .= _filter($_, '$tmp2') . "\n";
}
}
}
if (substr($val,0,1) eq '$') {
substr($val,0,1) = '';
$val = q|$self->_get_var(q{| . _text_escape($val) . q|})|;
}
elsif ($val =~ /^['"]/) {
$val = _quoted_string($val);
}
elsif (my $funccode = $self->_check_func($val)) {
$val = q|(| . $funccode . q< || '')>;
}
else {
$val = q|q{| . _text_escape($val) . q|}|;
}
if ($val_filters) {
$return .= $indent x $indent_level;
$return .= "\$tmp3 = $val;\n";
$val = '$tmp3';
for (reverse split ' ', $val_filters) {
$return .= $indent x $indent_level;
$return .= _filter($_, '$tmp3') . "\n";
}
}
my $calc;
if ($set and not defined $var) {
$calc = $val;
}
else {
$calc = _math($var, $comp, $val);
}
$return .= $indent x $indent_level;
if ($set) {
$return .= q|$tags->{q{| . _text_escape($setvar) . q|}} = \do { my $none = (|;
if ($change) {
# Passing $escape is required here, because what we save back
# is always a reference, thus the escaping has to occur here.
# $strict, however, is NOT passed because we aren't interested
# in variables becoming "Unknown tag: '....'"-type values.
$return .= _math(q|$self->_get_var(q{| . _text_escape($setvar) . q|}, $escape)|, $change, $calc);
}
else {
$return .= $calc;
}
$return .= ') }';
}
else {
$return .= ($print ? 'print ' : q|$return .= |) . $calc;
}
$return .= qq|;
|; }
# Filters: 'escape_url', 'unescape_url', 'escape_html', 'unescape_html', 'escape_js', 'uc', 'ucfirst', 'lc', 'lcfirst', 'nbsp'
elsif ($tag =~ /^($RE_FILTERS)(\S+)/o) {
my $var = $2;
my @filters = reverse split ' ', $1;
$return .= $indent x $indent_level++;
$return .= q|if (($tmp) = $self->_raw_value(q{| . _text_escape($var) . q|})) {
|; $return .= $indent x $indent_level;
$return .= q|$tmp = $$tmp if ref $tmp eq 'SCALAR' or ref $tmp eq 'LVALUE';
|; $return .= $indent x $indent_level++;
$return .= q|if (ref $tmp) {
|; $return .= $indent x $indent_level;
$text->(sprintf $ERRORS->{NOSCALAR}, $var);
$return .= $indent x ($indent_level - 1) . q|}
|; $return .= $indent x ($indent_level - 1) . q|else {
|; $return .= $indent x $indent_level;
$return .= q|$tmp = $self->_get_var(q{| . _text_escape($var) . q|}, $escape);
|; for (@filters) {
$return .= $indent x $indent_level;
$return .= _filter($_) . "\n";
}
$return .= $indent x $indent_level;
$return .= ($print ? q|print| : q|$return .=|) . q| $tmp;
|; $return .= $indent x --$indent_level . q|}
|; $return .= $indent x ($indent_level - 1) . q|}
|; $return .= $indent x ($indent_level - 1) . q|else {
|; $return .= $indent x $indent_level;
$text->(sprintf $ERRORS->{UNKNOWNTAG}, $var);
$return .= $indent x --$indent_level . q|}
|; }
# 'DUMP variable'
elsif ($tag =~ /^DUMP\s+\$?(\w+(?:\.\$?\w+)*)$/) {
my $func = qq{\$self->_call_func('GT::Template::dump', -auto => 1, -var => '$1')};
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|; }
elsif (my $func = $self->_check_func($tag)) {
$return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|; }
else {
# Check to see if it's a valid variable, function call, etc. Force
# strict on because this is some sort of strange tag that doesn't
# appear to be a variable, which should always produce an "Unknown
# tag" warning.
$return .= $indent x $indent_level;
$return .= ($print ? q|print| : q|$return .=|) . q| $tmp if defined($tmp = $self->_get_var(q{| . _text_escape($tag) . q|}, $escape, 1));
|; }
}
$text->(substr($tpl, $last_pos));
while ($indent_level > 0) {
$return .= ($indent x --$indent_level) . q|}
| }
$return .= $print ? q|return 1;| : q|return \$return;|;
return \$return;
}
# Handles quoted string semantics.
#
# Inside double-quote strings:
# \ can preceed any non-word character to mean the character itself - following
# word characters the following escapes are currently supported: \n, \r, \t,
# \000 (octal character value), \x00 (hex character value). \ followed by any
# other word character is undefined behaviour and should not be used.
# Variables are interpolated - you can write a variable as $foo.bar or
# ${foo.bar}. Inner-variable interpolation (such as what happens in
# <%foo.$bar%> is supported only in the latter form: ${foo.$bar} - $foo.$bar
# would end up becoming the value of foo, a ., then the value of bar.
#
# Inside single-quote strings:
# \ can preceed \ or ' to mean the value; preceeding anything else a \ is a
# literal \
%ESCAPE_MAP = (
t => '\t',
n => '\n',
r => '\r',
);
sub _quoted_string {
my $string = shift;
if ($string =~ s/^"//) {
$string =~ s/"$//;
$string =~ s[
(\\) # $1 A backslash escape of some sort
(?:
(x[0-9a-fA-F]{2}) # $2 - \x5b - a hex char
|
([0-7]{1,3}) # $3 - \123 - an octal char
|
(\w) # $4 - a word char - \n, \t, etc.
|
(\W) # $5 - a non word char - \\, \", etc.
)
|
\$ # The dollar sign that starts a variable
(?:
{ # opening { in a ${var}-style variable ## vim: }
(\w+(?:\.\$?\w+)*) # $6 - the inner part of a ${var} variable
}
|
(\w+) # $7 - the name of a $var-style variable
)
|
([{}\\]) # $8 - a character that needs to be escaped inside the q{}-delimited string - the \\ will only
# match at the very end of the string - though "string\" isn't really valid.
][
if ($1) { # a \ escape
if (my $code = $2 || $3) {
qq|}."\\$code".q{|;
}
elsif (exists $ESCAPE_MAP{$4}) {
qq|}."$ESCAPE_MAP{$4}".q{|;
}
elsif (defined $4) {
qq|}."$4".q{|;
}
else {
qq|}."\\$5".q{|;
}
}
elsif ($8) {
"\\$8"
}
else { # A variable
my $variable = $6 || $7;
q|}.$self->_get_var(q{| . _text_escape($variable) . q|}).q{|;
}
]egsx;
}
elsif ($string =~ s/^'//) {
$string =~ s/'$//;
$string =~ s/\\(['\\])/$1/g;
$string = _text_escape($string);
}
"q{$string}";
}
sub _math {
my ($left, $comp, $right) = @_; # var => left, val => right
my $calc;
if ($comp =~ /^[.*+-]$/ or $comp eq '||' or $comp eq '&&') { $calc = "+(($left) $comp ($right))" }
elsif ($comp =~ m{^/(\d+)$}) { $calc = "+sprintf(q{%.$1f}, (((\$tmp = ($right)) != 0) ? (($left) / \$tmp) : 0))" }
elsif ($comp eq '/') { $calc = "+(((\$tmp = ($right)) != 0) ? ($left / \$tmp) : 0)" }
elsif ($comp eq 'i/') { $calc = "int(((\$tmp = ($right)) != 0) ? (int($left) / int(\$tmp)) : 0)" }
elsif ($comp eq '%') { $calc = "+(((\$tmp = ($right)) != 0) ? ($left % \$tmp) : 0)" }
elsif ($comp eq '~') { $calc = "+(((\$tmp = ($right)) != 0) ? (\$tmp - ($left % \$tmp)) : 1)" }
elsif ($comp eq '^') { $calc = "+(($left) ** ($right))" }
elsif ($comp eq 'x') { $calc = "+(scalar($left) x ($right))" }
$calc ||= '';
$calc;
}
sub _loop_on {
my ($self, $on, $indent, $indent_level, $loop_depth) = @_;
my $var;
if ($on =~ /^(\d+|\$[\w.\$-]+)\s+(?:\.\.|to)\s+(\d+|\$[\w.\$-]+)$/) {
my ($start, $end) = ($1, $2);
for ($start, $end) {
$_ = q|int(do { my $v = $self->_get_var(q{| . _text_escape($_) . q|}); ref $v ? 0 : $v })|
if s/^\$//;
}
$var = "[$start .. $end]";
}
elsif (index($on, '::') > 0 or index($on, '(') > 0) {
$var = $self->_check_func($on);
}
else {
$on =~ s/^\$//;
$var = q|$self->_raw_value(q{| . _text_escape($on) . q|})|;
}
my $print = $self->{opt}->{print};
my $i0 = $indent x $indent_level;
my $i = $indent x ($indent_level + 1);
my $i____ = $indent x ($indent_level + 2);
my $i________ = $indent x ($indent_level + 3);
my $i____________ = $indent x ($indent_level + 4);
my $i________________ = $indent x ($indent_level + 5);
my $return = <<CODE;
${i0}\{
${i}my \$orig = {\%{\$self->{VARS}}};
${i}my %loop_set;
${i}LOOP$loop_depth: \{
${i____}my \$loop_var = $var;
${i____}my \$loop_type = ref \$loop_var;
${i____}if (\$loop_type eq 'CODE' or \$loop_type eq 'ARRAY') {
${i________}my \$next;
${i________}my \$row_num = 0;
${i________}my \$i = 0;
${i________}my \$current = \$loop_type eq 'CODE' ? \$loop_var->() : \$loop_var->[\$i++];
${i________}if (ref \$current eq 'ARRAY') {
${i____________}\$loop_type = 'ARRAY';
${i____________}\$loop_var = \$current;
${i____________}\$current = \$loop_var->[\$i++];
${i________}}
${i________}while (defined \$current) {
${i____________}if (\$loop_type eq 'CODE') {
${i________________}\$next = \$loop_var->();
${i____________}}
${i____________}else {
${i________________}\$next = \$loop_var->[\$i++];
${i____________}}
${i____________}my \$copy = {\%{\$self->{VARS}}};
${i____________}for (keys %loop_set) {
${i________________}\$copy->{\$_} = \$orig->{\$_};
${i________________}delete \$loop_set{\$_};
${i____________}}
${i____________}for (qw/row_num first last inner even odd loop_value/, keys \%\$current) { \$loop_set{\$_} = 1 }
${i____________}\$copy->{row_num} = ++\$row_num;
${i____________}\$copy->{first} = (\$row_num == 1) || 0;
${i____________}\$copy->{last} = (!\$next) || 0;
${i____________}\$copy->{inner} = (!\$copy->{first} and !\$copy->{last}) || 0;
${i____________}\$copy->{even} = (\$row_num % 2 == 0) || 0;
${i____________}\$copy->{odd} = (not \$copy->{even}) || 0;
${i____________}if (ref \$current ne 'HASH') { \$current = { loop_value => \$current } }
${i____________}else { \$loop_set{loop_value} = 1; \$copy->{loop_value} = \$current }
${i____________}for (keys \%\$current) { \$copy->{\$_} = \$current->{\$_} }
${i____________}\$self->{VARS} = \$copy;
${i____________}\$current = \$next;
CODE
$_[3] += 4; # Update the indent level
return $return;
}
sub _check_func {
# ---------------------------------------------------------------
# Takes a string and if it looks like a function, returns a string
# that will call the function with the appropriate arguments.
#
# So, you enter the tag (without the <% and %>):
# <%GFoo::function($foo, $bar, $boo, $far, '7', 'text')%>
# and you'll get back:
# $self->_call_func('GFoo::function', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});
# <%codevar($foo, $bar, $boo, $far => 7, text)%>
# $self->_call_func('codevar', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});
# NOTE: NO SEMICOLON (;) ON THE END
# which will require GFoo and call GFoo::function with the arguments provided.
#
# If you call this with a tag that doesn't look like a function, undef is returned.
#
my ($self, $str) = @_;
my $ret;
if (((index($str, '(') >= 0 and rindex($str, ')') >= 0) or index($str, '::') >= 1) and $str =~ /^
(?:
# Package $1
(
\w+
(?:
::
\w+
)*
)
::
)?
# Function $2
(
\w+
)
\s*
# Any possible arguments
(?:
\(
\s*
(
.+? # Arguments list $3
)?
\s*
\)
)?
$/sx) {
my ($package, $func, $args) = ($1, $2, $3);
$ret = '';
$args = '' if not defined $args;
$args = join ", ", _parse_args($args) if length $args;
$ret = q|$self->_call_func('| . ($package ? "$package\::$func" : $func) . q|'|;
$ret .= ", $args" if $args;
$ret .= ")";
}
return $ret;
}
sub _parse_args {
# --------------------------------------------------------
# Splits up arguments on commas outside of quotes. Unquotes
#
my $line = shift;
my ($word, @pieces);
local $^W;
while (length $line) {
my ($quoted, undef, $bareword, $delim) = $line =~ m{
^
(?:
( # $quoted test
(["']) # the actual quote
(?:\\.|(?!\2)[^\\])* # the text
\2 # followed by the same quote
)
| # --OR--
((?:\\.|[^\\"'])*?) # $bareword text, plus:
( # $delim
\Z(?!\n) # EOL
|
\s*(?:,|=>)\s* # delimiter
|
(?!^)(?=["']) # or quote
)
)
(.*) # and the rest ($+)
}sx;
return unless $quoted or length $bareword or length $delim;
$line = $+;
my $val;
if ($quoted) {
$val = _quoted_string($quoted);
}
elsif ($bareword =~ s/^\$//) {
$val = q|$self->_get_var(q{| . _text_escape($bareword) . q|},0,0)|;
}
elsif (length $bareword) {
$bareword =~ s/\\(.)/$1/g;
$val = q|q{| . _text_escape($bareword) . q|}|;
}
$word = $word ? "$word.$val" : $val if defined $val;
if (length $delim) {
push @pieces, $word;
$word = undef;
}
}
push @pieces, $word if defined $word;
return @pieces;
}
1;

198
site/glist/lib/GT/Template/Vars.pm Normal file
View File

@@ -0,0 +1,198 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Template::Vars
# Author: Jason Rhinelander
# CVS Info :
# $Id: Vars.pm,v 1.3 2005/03/05 01:17:20 jagerman Exp $
#
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# GT::Template variable handling tied hash reference.
#
package GT::Template::Vars;
use strict;
use Carp 'croak';
sub TIEHASH {
my ($class, $tpl) = @_;
my $self = { t => $tpl, keys => [] };
bless $self, ref $class || $class;
}
sub STORE {
my ($self, $key, $value) = @_;
if ($key =~ /^\w+(?:\.\$?\w+)+$/) {
my $cur = \$self->{t}->{VARS};
my @set = split /\./, $key;
for (my $i = 0; $i < @set; $i++) {
if ($set[$i] =~ /^\$/) {
my $val = $self->{t}->_get_var(substr($set[$i], 1));
$val = '' if not defined $val;
my @pieces = split /\./, $val;
@pieces = '' if !@pieces;
splice @set, $i, 1, @pieces;
$i += @pieces - 1 if @pieces > 1;
}
}
while (@set) {
my $k = shift @set;
if ($k =~ s/^\$//) {
$k = '' . ($self->FETCH($k) || '');
}
if ($k =~ /^\d+$/ and ref $$cur eq 'ARRAY') {
$cur = \$$cur->[$k];
}
elsif (ref $$cur eq 'HASH' or not defined $$cur or UNIVERSAL::isa($$cur, 'GT::Config')) {
$cur = \$$cur->{$k};
}
elsif (UNIVERSAL::isa($$cur, 'GT::CGI') and !@set) {
# You can set a GT::CGI parameter, but only to a scalar value (or reference to a scalar value)
return $$cur->param(
$k => ((ref $value eq 'SCALAR' or ref $value eq 'LVALUE') and not ref $$value) ? $$value : "$value"
);
}
else {
croak 'Not a HASH reference';
}
}
$$cur = $value;
}
else {
$self->{t}->{VARS}->{$key} = $value;
}
}
# Fetching wraps around _get_var, using the template parser's escape value.
# Strict is never passed because we want $tags->{foo} to be false if it isn't
# set, instead of "Unknown tag 'foo'". In cases where overriding escape is
# necessary, _get_var is used directly. _get_var's fourth argument is used
# here to avoid a potential infinite loop caused by recalling code references
# when their value is implicitly retrieved (for example, in a "while-each"
# loop).
sub FETCH {
my ($self, $key) = @_;
my $value = $self->{t}->_raw_value($key, 1);
$value = $$value if ref $value eq 'SCALAR' or ref $value eq 'LVALUE';
return $value;
}
# Keys/exists are a little strange - if "foo" is set to { a => 1 }, exists
# $tags->{"foo.a"} will be true, but only "foo", not "foo.a", will be returned
# by keys %$tags.
sub FIRSTKEY {
my $self = shift;
my @keys;
for (keys %{$self->{t}->{VARS}}) {
push @keys, $_;
}
for (keys %{$self->{t}->{ALIAS}}) {
push @keys, $_ unless exists $self->{t}->{VARS}->{$_};
}
$self->{keys} = \@keys;
return shift @keys;
}
sub EXISTS {
my ($self, $key) = @_;
my @val = $self->{t}->_raw_value($key);
return !!@val;
}
sub NEXTKEY {
my $self = shift;
if (!$self->{keys}) {
return $self->FIRSTKEY;
}
elsif (!@{$self->{keys}}) {
delete $self->{keys};
return;
}
return shift @{$self->{keys}};
}
sub DELETE {
my ($self, $key) = @_;
my $value = $self->FETCH($key);
delete $self->{t}->{VARS}->{$key};
$value;
}
sub CLEAR { %{$_[0]->{t}->{VARS}} = () }
sub SCALAR { scalar %{$_[0]->{t}->{VARS}} }
1;
__END__
=head1 NAME
GT::Template::Vars - Tied hash for template tags handling
=head1 SYNOPSIS
my $vars = GT::Template->vars;
print $vars->{foo};
=head1 DESCRIPTION
This module is designed to provide a simple interface to GT::Template tags from
Perl code. Prior to this module, the tags() method of GT::Template returned a
hash reference which could contain all sorts of different values - scalar
references, LVALUE references, GT::Config objects, etc. This new interface
provides a tied hash reference designed to aid in retrieving and setting values
in the same way template variables are retrieved and set from templates.
=head1 INTERFACE
=head2 Accessing values
Accessing a value is simple - just access C<$vars-E<gt>{name}>. The regular
rules of escaping apply here: if the value would have been HTML-escaped in the
template, it will be escaped when you get it.
=head2 Setting values
Setting a value is easy - simply do: C<$vars-E<gt>{name} = $value;>. "name"
can be anything GT::Template recognises as a variable, so
C<$vars-E<gt>{'name.key'}> would set C<-E<gt>{name}-E<gt>{key}> (see
L<GT::Template::Tutorial/"Advanced variables using references"> for more
information on complex variables).
The regular rules of escaping apply here: if escaping is turned on, a value you
set will be escaped when accessed again via $vars or in a template. If you
want to set a tag containing raw HTML, you should set a scalar reference, such
as: C<$vars-E<gt>{name} = \$value;>.
=head2 Keys, Exists
You can use C<keys %$vars> to get a list of keys of the tag object, but you
should note that while C<$vars-E<gt>{"a.b"}> is valid and
C<exists $vars-E<gt>{"a.b"}> may return true, it will B<not> be present in the
list of keys returned by C<keys %$vars>.
=head1 SEE ALSO
L<GT::Template>
L<GT::Template::Tutorial>
=head1 MAINTAINER
Jason Rhinelander
=head1 COPYRIGHT
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Vars.pm,v 1.3 2005/03/05 01:17:20 jagerman Exp $
=cut