First pass at adding key files
This commit is contained in:
dsainty
417
site/glist/lib/GT/Template/Editor.pm
Normal file
417
site/glist/lib/GT/Template/Editor.pm
Normal 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
250
site/glist/lib/GT/Template/Inheritance.pm
Normal 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
987
site/glist/lib/GT/Template/Parser.pm
Normal 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/ /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
198
site/glist/lib/GT/Template/Vars.pm
Normal 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
|
||||
Reference in New Issue
Block a user