Initial Commit
This commit is contained in:
773
database/perl/vendor/lib/Template/Stash/Context.pm
vendored
Normal file
773
database/perl/vendor/lib/Template/Stash/Context.pm
vendored
Normal file
@@ -0,0 +1,773 @@
|
||||
#============================================================= -*-Perl-*-
|
||||
#
|
||||
# Template::Stash::Context
|
||||
#
|
||||
# DESCRIPTION
|
||||
# This is an alternate stash object which includes a patch from
|
||||
# Craig Barratt to implement various new virtual methods to allow
|
||||
# dotted template variable to denote if object methods and subroutines
|
||||
# should be called in scalar or list context. It adds a little overhead
|
||||
# to each stash call and I'm a little wary of doing that. So for now,
|
||||
# it's implemented as a separate stash module which will allow us to
|
||||
# test it out, benchmark it and switch it in or out as we require.
|
||||
#
|
||||
# This is what Craig has to say about it:
|
||||
#
|
||||
# Here's a better set of features for the core. Attached is a new version
|
||||
# of Stash.pm (based on TT2.02) that:
|
||||
#
|
||||
# - supports the special op "scalar" that forces scalar context on
|
||||
# function calls, eg:
|
||||
#
|
||||
# cgi.param("foo").scalar
|
||||
#
|
||||
# calls cgi.param("foo") in scalar context (unlike my wimpy
|
||||
# scalar op from last night). Array context is the default.
|
||||
#
|
||||
# With non-function operands, scalar behaves like the perl
|
||||
# version (eg: no-op for scalar, size for arrays, etc).
|
||||
#
|
||||
# - supports the special op "ref" that behaves like the perl ref.
|
||||
# If applied to a function the function is not called. Eg:
|
||||
#
|
||||
# cgi.param("foo").ref
|
||||
#
|
||||
# does *not* call cgi.param and evaluates to "CODE". Similarly,
|
||||
# HASH.ref, ARRAY.ref return what you expect.
|
||||
#
|
||||
# - adds a new scalar and list op called "array" that is a no-op for
|
||||
# arrays and promotes scalars to one-element arrays.
|
||||
#
|
||||
# - allows scalar ops to be applied to arrays and hashes in place,
|
||||
# eg: ARRAY.repeat(3) repeats each element in place.
|
||||
#
|
||||
# - allows list ops to be applied to scalars by promoting the scalars
|
||||
# to one-element arrays (like an implicit "array"). So you can
|
||||
# do things like SCALAR.size, SCALAR.join and get a useful result.
|
||||
#
|
||||
# This also means you can now use x.0 to safely get the first element
|
||||
# whether x is an array or scalar.
|
||||
#
|
||||
# The new Stash.pm passes the TT2.02 test suite. But I haven't tested the
|
||||
# new features very much. One nagging implementation problem is that the
|
||||
# "scalar" and "ref" ops have higher precedence than user variable names.
|
||||
#
|
||||
# AUTHORS
|
||||
# Andy Wardley <abw@kfs.org>
|
||||
# Craig Barratt <craig@arraycomm.com>
|
||||
#
|
||||
# COPYRIGHT
|
||||
# Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved.
|
||||
# Copyright (C) 1998-2001 Canon Research Centre Europe Ltd.
|
||||
#
|
||||
# This module is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
#
|
||||
#============================================================================
|
||||
|
||||
package Template::Stash::Context;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use base 'Template::Stash';
|
||||
|
||||
our $VERSION = '3.009';
|
||||
our $DEBUG = 0 unless defined $DEBUG;
|
||||
|
||||
|
||||
#========================================================================
|
||||
# -- PACKAGE VARIABLES AND SUBS --
|
||||
#========================================================================
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# copy virtual methods from those in the regular Template::Stash
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
our $ROOT_OPS = {
|
||||
%$Template::Stash::ROOT_OPS,
|
||||
defined $ROOT_OPS ? %$ROOT_OPS : (),
|
||||
};
|
||||
|
||||
our $SCALAR_OPS = {
|
||||
%$Template::Stash::SCALAR_OPS,
|
||||
'array' => sub { return [$_[0]] },
|
||||
defined $SCALAR_OPS ? %$SCALAR_OPS : (),
|
||||
};
|
||||
|
||||
our $LIST_OPS = {
|
||||
%$Template::Stash::LIST_OPS,
|
||||
'array' => sub { return $_[0] },
|
||||
defined $LIST_OPS ? %$LIST_OPS : (),
|
||||
};
|
||||
|
||||
our $HASH_OPS = {
|
||||
%$Template::Stash::HASH_OPS,
|
||||
defined $HASH_OPS ? %$HASH_OPS : (),
|
||||
};
|
||||
|
||||
|
||||
|
||||
#========================================================================
|
||||
# ----- CLASS METHODS -----
|
||||
#========================================================================
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# new(\%params)
|
||||
#
|
||||
# Constructor method which creates a new Template::Stash object.
|
||||
# An optional hash reference may be passed containing variable
|
||||
# definitions that will be used to initialise the stash.
|
||||
#
|
||||
# Returns a reference to a newly created Template::Stash.
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
|
||||
|
||||
my $self = {
|
||||
global => { },
|
||||
%$params,
|
||||
%$ROOT_OPS,
|
||||
'_PARENT' => undef,
|
||||
'_CLASS' => $class,
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
|
||||
#========================================================================
|
||||
# ----- PUBLIC OBJECT METHODS -----
|
||||
#========================================================================
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# clone(\%params)
|
||||
#
|
||||
# Creates a copy of the current stash object to effect localisation
|
||||
# of variables. The new stash is blessed into the same class as the
|
||||
# parent (which may be a derived class) and has a '_PARENT' member added
|
||||
# which contains a reference to the parent stash that created it
|
||||
# ($self). This member is used in a successive declone() method call to
|
||||
# return the reference to the parent.
|
||||
#
|
||||
# A parameter may be provided which should reference a hash of
|
||||
# variable/values which should be defined in the new stash. The
|
||||
# update() method is called to define these new variables in the cloned
|
||||
# stash.
|
||||
#
|
||||
# Returns a reference to a cloned Template::Stash.
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub clone {
|
||||
my ($self, $params) = @_;
|
||||
$params ||= { };
|
||||
|
||||
# look out for magical 'import' argument which imports another hash
|
||||
my $import = $params->{ import };
|
||||
if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
|
||||
delete $params->{ import };
|
||||
}
|
||||
else {
|
||||
undef $import;
|
||||
}
|
||||
|
||||
my $clone = bless {
|
||||
%$self, # copy all parent members
|
||||
%$params, # copy all new data
|
||||
'_PARENT' => $self, # link to parent
|
||||
}, ref $self;
|
||||
|
||||
# perform hash import if defined
|
||||
&{ $HASH_OPS->{ import }}($clone, $import)
|
||||
if defined $import;
|
||||
|
||||
return $clone;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# declone($export)
|
||||
#
|
||||
# Returns a reference to the PARENT stash. When called in the following
|
||||
# manner:
|
||||
# $stash = $stash->declone();
|
||||
# the reference count on the current stash will drop to 0 and be "freed"
|
||||
# and the caller will be left with a reference to the parent. This
|
||||
# contains the state of the stash before it was cloned.
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub declone {
|
||||
my $self = shift;
|
||||
$self->{ _PARENT } || $self;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# get($ident)
|
||||
#
|
||||
# Returns the value for an variable stored in the stash. The variable
|
||||
# may be specified as a simple string, e.g. 'foo', or as an array
|
||||
# reference representing compound variables. In the latter case, each
|
||||
# pair of successive elements in the list represent a node in the
|
||||
# compound variable. The first is the variable name, the second a
|
||||
# list reference of arguments or 0 if undefined. So, the compound
|
||||
# variable [% foo.bar('foo').baz %] would be represented as the list
|
||||
# [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the
|
||||
# identifier or an empty string if undefined. Errors are thrown via
|
||||
# die().
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub get {
|
||||
my ($self, $ident, $args) = @_;
|
||||
my ($root, $result);
|
||||
$root = $self;
|
||||
|
||||
if (ref $ident eq 'ARRAY'
|
||||
|| ($ident =~ /\./)
|
||||
&& ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) {
|
||||
my $size = $#$ident;
|
||||
|
||||
# if $ident is a list reference, then we evaluate each item in the
|
||||
# identifier against the previous result, using the root stash
|
||||
# ($self) as the first implicit 'result'...
|
||||
|
||||
foreach (my $i = 0; $i <= $size; $i += 2) {
|
||||
if ( $i + 2 <= $size && ($ident->[$i+2] eq "scalar"
|
||||
|| $ident->[$i+2] eq "ref") ) {
|
||||
$result = $self->_dotop($root, @$ident[$i, $i+1], 0,
|
||||
$ident->[$i+2]);
|
||||
$i += 2;
|
||||
} else {
|
||||
$result = $self->_dotop($root, @$ident[$i, $i+1]);
|
||||
}
|
||||
last unless defined $result;
|
||||
$root = $result;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$result = $self->_dotop($root, $ident, $args);
|
||||
}
|
||||
|
||||
return defined $result
|
||||
? $result
|
||||
: $self->undefined($ident, $args);
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# set($ident, $value, $default)
|
||||
#
|
||||
# Updates the value for a variable in the stash. The first parameter
|
||||
# should be the variable name or array, as per get(). The second
|
||||
# parameter should be the intended value for the variable. The third,
|
||||
# optional parameter is a flag which may be set to indicate 'default'
|
||||
# mode. When set true, the variable will only be updated if it is
|
||||
# currently undefined or has a false value. The magical 'IMPORT'
|
||||
# variable identifier may be used to indicate that $value is a hash
|
||||
# reference whose values should be imported. Returns the value set,
|
||||
# or an empty string if not set (e.g. default mode). In the case of
|
||||
# IMPORT, returns the number of items imported from the hash.
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub set {
|
||||
my ($self, $ident, $value, $default) = @_;
|
||||
my ($root, $result, $error);
|
||||
|
||||
$root = $self;
|
||||
|
||||
ELEMENT: {
|
||||
if (ref $ident eq 'ARRAY'
|
||||
|| ($ident =~ /\./)
|
||||
&& ($ident = [ map { s/\(.*$//; ($_, 0) }
|
||||
split(/\./, $ident) ])) {
|
||||
|
||||
# a compound identifier may contain multiple elements (e.g.
|
||||
# foo.bar.baz) and we must first resolve all but the last,
|
||||
# using _dotop() with the $lvalue flag set which will create
|
||||
# intermediate hashes if necessary...
|
||||
my $size = $#$ident;
|
||||
foreach (my $i = 0; $i < $size - 2; $i += 2) {
|
||||
$result = $self->_dotop($root, @$ident[$i, $i+1], 1);
|
||||
last ELEMENT unless defined $result;
|
||||
$root = $result;
|
||||
}
|
||||
|
||||
# then we call _assign() to assign the value to the last element
|
||||
$result = $self->_assign($root, @$ident[$size-1, $size],
|
||||
$value, $default);
|
||||
}
|
||||
else {
|
||||
$result = $self->_assign($root, $ident, 0, $value, $default);
|
||||
}
|
||||
}
|
||||
|
||||
return defined $result ? $result : '';
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# getref($ident)
|
||||
#
|
||||
# Returns a "reference" to a particular item. This is represented as a
|
||||
# closure which will return the actual stash item when called.
|
||||
# WARNING: still experimental!
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub getref {
|
||||
my ($self, $ident, $args) = @_;
|
||||
my ($root, $item, $result);
|
||||
$root = $self;
|
||||
|
||||
if (ref $ident eq 'ARRAY') {
|
||||
my $size = $#$ident;
|
||||
|
||||
foreach (my $i = 0; $i <= $size; $i += 2) {
|
||||
($item, $args) = @$ident[$i, $i + 1];
|
||||
last if $i >= $size - 2; # don't evaluate last node
|
||||
last unless defined
|
||||
($root = $self->_dotop($root, $item, $args));
|
||||
}
|
||||
}
|
||||
else {
|
||||
$item = $ident;
|
||||
}
|
||||
|
||||
if (defined $root) {
|
||||
return sub { my @args = (@{$args||[]}, @_);
|
||||
$self->_dotop($root, $item, \@args);
|
||||
}
|
||||
}
|
||||
else {
|
||||
return sub { '' };
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# update(\%params)
|
||||
#
|
||||
# Update multiple variables en masse. No magic is performed. Simple
|
||||
# variable names only.
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub update {
|
||||
my ($self, $params) = @_;
|
||||
|
||||
# look out for magical 'import' argument to import another hash
|
||||
my $import = $params->{ import };
|
||||
if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
|
||||
@$self{ keys %$import } = values %$import;
|
||||
delete $params->{ import };
|
||||
}
|
||||
|
||||
@$self{ keys %$params } = values %$params;
|
||||
}
|
||||
|
||||
|
||||
#========================================================================
|
||||
# ----- PRIVATE OBJECT METHODS -----
|
||||
#========================================================================
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# _dotop($root, $item, \@args, $lvalue, $nextItem)
|
||||
#
|
||||
# This is the core 'dot' operation method which evaluates elements of
|
||||
# variables against their root. All variables have an implicit root
|
||||
# which is the stash object itself (a hash). Thus, a non-compound
|
||||
# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is
|
||||
# '(stash.)foo.bar'. The first parameter is a reference to the current
|
||||
# root, initially the stash itself. The second parameter contains the
|
||||
# name of the variable element, e.g. 'foo'. The third optional
|
||||
# parameter is a reference to a list of any parenthesised arguments
|
||||
# specified for the variable, which are passed to sub-routines, object
|
||||
# methods, etc. The final parameter is an optional flag to indicate
|
||||
# if this variable is being evaluated on the left side of an assignment
|
||||
# (e.g. foo.bar.baz = 10). When set true, intermediated hashes will
|
||||
# be created (e.g. bar) if necessary.
|
||||
#
|
||||
# Returns the result of evaluating the item against the root, having
|
||||
# performed any variable "magic". The value returned can then be used
|
||||
# as the root of the next _dotop() in a compound sequence. Returns
|
||||
# undef if the variable is undefined.
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub _dotop {
|
||||
my ($self, $root, $item, $args, $lvalue, $nextItem) = @_;
|
||||
my $rootref = ref $root;
|
||||
my ($value, @result, $ret, $retVal);
|
||||
$nextItem ||= "";
|
||||
my $scalarContext = 1 if ( $nextItem eq "scalar" );
|
||||
my $returnRef = 1 if ( $nextItem eq "ref" );
|
||||
|
||||
$args ||= [ ];
|
||||
$lvalue ||= 0;
|
||||
|
||||
# print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n"
|
||||
# if $DEBUG;
|
||||
|
||||
# return undef without an error if either side of the dot is unviable
|
||||
# or if an attempt is made to access a private member, starting _ or .
|
||||
return undef
|
||||
unless defined($root) and defined($item) and $item !~ /^[\._]/;
|
||||
|
||||
if (ref(\$root) eq "SCALAR" && !$lvalue &&
|
||||
(($value = $LIST_OPS->{ $item }) || $item =~ /^-?\d+$/) ) {
|
||||
#
|
||||
# Promote scalar to one element list, to be processed below.
|
||||
#
|
||||
$rootref = 'ARRAY';
|
||||
$root = [$root];
|
||||
}
|
||||
if ($rootref eq $self->{_CLASS} || $rootref eq 'HASH') {
|
||||
|
||||
# if $root is a regular HASH or a Template::Stash kinda HASH (the
|
||||
# *real* root of everything). We first lookup the named key
|
||||
# in the hash, or create an empty hash in its place if undefined
|
||||
# and the $lvalue flag is set. Otherwise, we check the HASH_OPS
|
||||
# pseudo-methods table, calling the code if found, or return undef.
|
||||
|
||||
if (defined($value = $root->{ $item })) {
|
||||
($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
|
||||
$scalarContext);
|
||||
return $retVal if ( $ret ); ## RETURN
|
||||
}
|
||||
elsif ($lvalue) {
|
||||
# we create an intermediate hash if this is an lvalue
|
||||
return $root->{ $item } = { }; ## RETURN
|
||||
}
|
||||
elsif ($value = $HASH_OPS->{ $item }) {
|
||||
@result = &$value($root, @$args); ## @result
|
||||
}
|
||||
elsif (ref $item eq 'ARRAY') {
|
||||
# hash slice
|
||||
return [@$root{@$item}]; ## RETURN
|
||||
}
|
||||
elsif ($value = $SCALAR_OPS->{ $item }) {
|
||||
#
|
||||
# Apply scalar ops to every hash element, in place.
|
||||
#
|
||||
foreach my $key ( keys %$root ) {
|
||||
$root->{$key} = &$value($root->{$key}, @$args);
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($rootref eq 'ARRAY') {
|
||||
|
||||
# if root is an ARRAY then we check for a LIST_OPS pseudo-method
|
||||
# (except for l-values for which it doesn't make any sense)
|
||||
# or return the numerical index into the array, or undef
|
||||
|
||||
if (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
|
||||
@result = &$value($root, @$args); ## @result
|
||||
}
|
||||
elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
|
||||
#
|
||||
# Apply scalar ops to every array element, in place.
|
||||
#
|
||||
for ( my $i = 0 ; $i < @$root ; $i++ ) {
|
||||
$root->[$i] = &$value($root->[$i], @$args); ## @result
|
||||
}
|
||||
}
|
||||
elsif ($item =~ /^-?\d+$/) {
|
||||
$value = $root->[$item];
|
||||
($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
|
||||
$scalarContext);
|
||||
return $retVal if ( $ret ); ## RETURN
|
||||
}
|
||||
elsif (ref $item eq 'ARRAY' ) {
|
||||
# array slice
|
||||
return [@$root[@$item]]; ## RETURN
|
||||
}
|
||||
}
|
||||
|
||||
# NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
|
||||
# doesn't appear to work with CGI, returning true for the first call
|
||||
# and false for all subsequent calls.
|
||||
|
||||
elsif (ref($root) && UNIVERSAL::can($root, 'can')) {
|
||||
|
||||
# if $root is a blessed reference (i.e. inherits from the
|
||||
# UNIVERSAL object base class) then we call the item as a method.
|
||||
# If that fails then we try to fallback on HASH behaviour if
|
||||
# possible.
|
||||
return ref $root->can($item) if ( $returnRef ); ## RETURN
|
||||
eval {
|
||||
@result = $scalarContext ? scalar $root->$item(@$args)
|
||||
: $root->$item(@$args); ## @result
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
# failed to call object method, so try some fallbacks
|
||||
if (UNIVERSAL::isa($root, 'HASH')
|
||||
&& defined($value = $root->{ $item })) {
|
||||
($ret, $retVal, @result) = _dotop_return($value, $args,
|
||||
$returnRef, $scalarContext);
|
||||
return $retVal if ( $ret ); ## RETURN
|
||||
}
|
||||
elsif (UNIVERSAL::isa($root, 'ARRAY')
|
||||
&& ($value = $LIST_OPS->{ $item })) {
|
||||
@result = &$value($root, @$args);
|
||||
}
|
||||
else {
|
||||
@result = (undef, $@);
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
|
||||
|
||||
# at this point, it doesn't look like we've got a reference to
|
||||
# anything we know about, so we try the SCALAR_OPS pseudo-methods
|
||||
# table (but not for l-values)
|
||||
|
||||
@result = &$value($root, @$args); ## @result
|
||||
}
|
||||
elsif ($self->{ _DEBUG }) {
|
||||
die "don't know how to access [ $root ].$item\n"; ## DIE
|
||||
}
|
||||
else {
|
||||
@result = ();
|
||||
}
|
||||
|
||||
# fold multiple return items into a list unless first item is undef
|
||||
if (defined $result[0]) {
|
||||
return ref(@result > 1 ? [ @result ] : $result[0])
|
||||
if ( $returnRef ); ## RETURN
|
||||
if ( $scalarContext ) {
|
||||
return scalar @result if ( @result > 1 ); ## RETURN
|
||||
return scalar(@{$result[0]}) if ( ref $result[0] eq "ARRAY" );
|
||||
return scalar(%{$result[0]}) if ( ref $result[0] eq "HASH" );
|
||||
return $result[0]; ## RETURN
|
||||
} else {
|
||||
return @result > 1 ? [ @result ] : $result[0]; ## RETURN
|
||||
}
|
||||
}
|
||||
elsif (defined $result[1]) {
|
||||
die $result[1]; ## DIE
|
||||
}
|
||||
elsif ($self->{ _DEBUG }) {
|
||||
die "$item is undefined\n"; ## DIE
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
|
||||
# $scalarContext);
|
||||
#
|
||||
# Handle the various return processing for _dotop
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub _dotop_return
|
||||
{
|
||||
my($value, $args, $returnRef, $scalarContext) = @_;
|
||||
my(@result);
|
||||
|
||||
return (1, ref $value) if ( $returnRef ); ## RETURN
|
||||
if ( $scalarContext ) {
|
||||
return (1, scalar(@$value)) if ref $value eq 'ARRAY'; ## RETURN
|
||||
return (1, scalar(%$value)) if ref $value eq 'HASH'; ## RETURN
|
||||
return (1, scalar($value)) unless ref $value eq 'CODE'; ## RETURN;
|
||||
@result = scalar &$value(@$args) ## @result;
|
||||
} else {
|
||||
return (1, $value) unless ref $value eq 'CODE'; ## RETURN
|
||||
@result = &$value(@$args); ## @result
|
||||
}
|
||||
return (0, undef, @result);
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# _assign($root, $item, \@args, $value, $default)
|
||||
#
|
||||
# Similar to _dotop() above, but assigns a value to the given variable
|
||||
# instead of simply returning it. The first three parameters are the
|
||||
# root item, the item and arguments, as per _dotop(), followed by the
|
||||
# value to which the variable should be set and an optional $default
|
||||
# flag. If set true, the variable will only be set if currently false
|
||||
# (undefined/zero)
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub _assign {
|
||||
my ($self, $root, $item, $args, $value, $default) = @_;
|
||||
my $rootref = ref $root;
|
||||
my $result;
|
||||
$args ||= [ ];
|
||||
$default ||= 0;
|
||||
|
||||
# print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n",
|
||||
# "value=$value, default=$default)\n")
|
||||
# if $DEBUG;
|
||||
|
||||
# return undef without an error if either side of the dot is unviable
|
||||
# or if an attempt is made to update a private member, starting _ or .
|
||||
return undef ## RETURN
|
||||
unless $root and defined $item and $item !~ /^[\._]/;
|
||||
|
||||
if ($rootref eq 'HASH' || $rootref eq $self->{_CLASS}) {
|
||||
# if the root is a hash we set the named key
|
||||
return ($root->{ $item } = $value) ## RETURN
|
||||
unless $default && $root->{ $item };
|
||||
}
|
||||
elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) {
|
||||
# or set a list item by index number
|
||||
return ($root->[$item] = $value) ## RETURN
|
||||
unless $default && $root->{ $item };
|
||||
}
|
||||
elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) {
|
||||
# try to call the item as a method of an object
|
||||
return $root->$item(@$args, $value); ## RETURN
|
||||
}
|
||||
else {
|
||||
die "don't know how to assign to [$root].[$item]\n"; ## DIE
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# _dump()
|
||||
#
|
||||
# Debug method which returns a string representing the internal state
|
||||
# of the object. The method calls itself recursively to dump sub-hashes.
|
||||
#------------------------------------------------------------------------
|
||||
|
||||
sub _dump {
|
||||
my $self = shift;
|
||||
my $indent = shift || 1;
|
||||
my $buffer = ' ';
|
||||
my $pad = $buffer x $indent;
|
||||
my $text = '';
|
||||
local $" = ', ';
|
||||
|
||||
my ($key, $value);
|
||||
|
||||
|
||||
return $text . "...excessive recursion, terminating\n"
|
||||
if $indent > 32;
|
||||
|
||||
foreach $key (keys %$self) {
|
||||
|
||||
$value = $self->{ $key };
|
||||
$value = '<undef>' unless defined $value;
|
||||
|
||||
if (ref($value) eq 'ARRAY') {
|
||||
$value = "$value [@$value]";
|
||||
}
|
||||
$text .= sprintf("$pad%-8s => $value\n", $key);
|
||||
next if $key =~ /^\./;
|
||||
if (UNIVERSAL::isa($value, 'HASH')) {
|
||||
$text .= _dump($value, $indent + 1);
|
||||
}
|
||||
}
|
||||
$text;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Template::Stash::Context - Experimetal stash allowing list/scalar context definition
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Template;
|
||||
use Template::Stash::Context;
|
||||
|
||||
my $stash = Template::Stash::Context->new(\%vars);
|
||||
my $tt2 = Template->new({ STASH => $stash });
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an alternate stash object which includes a patch from
|
||||
Craig Barratt to implement various new virtual methods to allow
|
||||
dotted template variable to denote if object methods and subroutines
|
||||
should be called in scalar or list context. It adds a little overhead
|
||||
to each stash call and I'm a little wary of applying that to the core
|
||||
default stash without investigating the effects first. So for now,
|
||||
it's implemented as a separate stash module which will allow us to
|
||||
test it out, benchmark it and switch it in or out as we require.
|
||||
|
||||
This is what Craig has to say about it:
|
||||
|
||||
Here's a better set of features for the core. Attached is a new version
|
||||
of Stash.pm (based on TT2.02) that:
|
||||
|
||||
* supports the special op "scalar" that forces scalar context on
|
||||
function calls, eg:
|
||||
|
||||
cgi.param("foo").scalar
|
||||
|
||||
calls cgi.param("foo") in scalar context (unlike my wimpy
|
||||
scalar op from last night). Array context is the default.
|
||||
|
||||
With non-function operands, scalar behaves like the perl
|
||||
version (eg: no-op for scalar, size for arrays, etc).
|
||||
|
||||
* supports the special op "ref" that behaves like the perl ref.
|
||||
If applied to a function the function is not called. Eg:
|
||||
|
||||
cgi.param("foo").ref
|
||||
|
||||
does *not* call cgi.param and evaluates to "CODE". Similarly,
|
||||
HASH.ref, ARRAY.ref return what you expect.
|
||||
|
||||
* adds a new scalar and list op called "array" that is a no-op for
|
||||
arrays and promotes scalars to one-element arrays.
|
||||
|
||||
* allows scalar ops to be applied to arrays and hashes in place,
|
||||
eg: ARRAY.repeat(3) repeats each element in place.
|
||||
|
||||
* allows list ops to be applied to scalars by promoting the scalars
|
||||
to one-element arrays (like an implicit "array"). So you can
|
||||
do things like SCALAR.size, SCALAR.join and get a useful result.
|
||||
|
||||
This also means you can now use x.0 to safely get the first element
|
||||
whether x is an array or scalar.
|
||||
|
||||
The new Stash.pm passes the TT2.02 test suite. But I haven't tested the
|
||||
new features very much. One nagging implementation problem is that the
|
||||
"scalar" and "ref" ops have higher precedence than user variable names.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Andy Wardley E<lt>abw@wardley.orgE<gt>
|
||||
|
||||
L<http://wardley.org/|http://wardley.org/>
|
||||
|
||||
|
||||
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
1.63, distributed as part of the
|
||||
Template Toolkit version 3.009, released on 30 March 2020.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
|
||||
|
||||
|
||||
This module is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Template::Stash|Template::Stash>
|
||||
|
||||
=cut
|
||||
|
||||
# Local Variables:
|
||||
# mode: perl
|
||||
# perl-indent-level: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
#
|
||||
# vim: expandtab shiftwidth=4:
|
||||
129
database/perl/vendor/lib/Template/Stash/XS.pm
vendored
Normal file
129
database/perl/vendor/lib/Template/Stash/XS.pm
vendored
Normal file
@@ -0,0 +1,129 @@
|
||||
#============================================================= -*-Perl-*-
|
||||
#
|
||||
# Template::Stash::XS
|
||||
#
|
||||
# DESCRIPTION
|
||||
#
|
||||
# Perl bootstrap for XS module. Inherits methods from
|
||||
# Template::Stash when not implemented in the XS module.
|
||||
#
|
||||
#========================================================================
|
||||
|
||||
package Template::Stash::XS;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Template;
|
||||
use Template::Stash;
|
||||
use XSLoader;
|
||||
|
||||
our $AUTOLOAD;
|
||||
|
||||
our @ISA = qw( Template::Stash );
|
||||
|
||||
XSLoader::load 'Template::Stash::XS', $Template::VERSION;
|
||||
|
||||
sub DESTROY {
|
||||
# no op
|
||||
1;
|
||||
}
|
||||
|
||||
# catch missing method calls here so perl doesn't barf
|
||||
# trying to load *.al files
|
||||
|
||||
sub AUTOLOAD {
|
||||
my ($self, @args) = @_;
|
||||
my @c = caller(0);
|
||||
my $auto = $AUTOLOAD;
|
||||
|
||||
$auto =~ s/.*:://;
|
||||
$self =~ s/=.*//;
|
||||
|
||||
die "Can't locate object method \"$auto\"" .
|
||||
" via package \"$self\" at $c[1] line $c[2]\n";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Template::Stash::XS - High-speed variable stash written in C
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Template;
|
||||
use Template::Stash::XS;
|
||||
|
||||
my $stash = Template::Stash::XS->new(\%vars);
|
||||
my $tt2 = Template->new({ STASH => $stash });
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The Template:Stash::XS module is an implementation of the
|
||||
Template::Stash written in C. The "XS" in the name refers to Perl's
|
||||
XS extension system for interfacing Perl to C code. It works just
|
||||
like the regular Perl implementation of Template::Stash but runs about
|
||||
twice as fast.
|
||||
|
||||
The easiest way to use the XS stash is to configure the Template
|
||||
Toolkit to use it by default. You can do this at installation time
|
||||
(when you run C<perl Makefile.PL>) by answering 'y' to the questions:
|
||||
|
||||
Do you want to build the XS Stash module? y
|
||||
Do you want to use the XS Stash by default? y
|
||||
|
||||
See the F<INSTALL> file distributed with the Template Toolkit for further
|
||||
details on installation.
|
||||
|
||||
If you don't elect to use the XS stash by default then you should use
|
||||
the C<STASH> configuration item when you create a new Template object.
|
||||
This should reference an XS stash object that you have created
|
||||
manually.
|
||||
|
||||
use Template;
|
||||
use Template::Stash::XS;
|
||||
|
||||
my $stash = Template::Stash::XS->new(\%vars);
|
||||
my $tt2 = Template->new({ STASH => $stash });
|
||||
|
||||
Alternately, you can set the C<$Template::Config::STASH> package
|
||||
variable like so:
|
||||
|
||||
use Template;
|
||||
use Template::Config;
|
||||
|
||||
$Template::Config::STASH = 'Template::Stash::XS';
|
||||
|
||||
my $tt2 = Template->new();
|
||||
|
||||
The XS stash will then be automatically used.
|
||||
|
||||
If you want to use the XS stash by default and don't want to
|
||||
re-install the Template Toolkit, then you can manually modify the
|
||||
C<Template/Config.pm> module near line 42 to read:
|
||||
|
||||
$STASH = 'Template::Stash::XS';
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report bugs to the Template Toolkit mailing list
|
||||
templates@template-toolkit.org
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/>
|
||||
|
||||
Doug Steinwand E<lt>dsteinwand@citysearch.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 1996-2013 Andy Wardley. All Rights Reserved.
|
||||
|
||||
This module is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Template::Stash>
|
||||
Reference in New Issue
Block a user