summaryrefslogtreecommitdiff
path: root/lib/Template/Stash.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Template/Stash.pm')
-rw-r--r--lib/Template/Stash.pm1000
1 files changed, 1000 insertions, 0 deletions
diff --git a/lib/Template/Stash.pm b/lib/Template/Stash.pm
new file mode 100644
index 0000000..4f26bca
--- /dev/null
+++ b/lib/Template/Stash.pm
@@ -0,0 +1,1000 @@
+#============================================================= -*-Perl-*-
+#
+# Template::Stash
+#
+# DESCRIPTION
+# Definition of an object class which stores and manages access to
+# variables for the Template Toolkit.
+#
+# AUTHOR
+# Andy Wardley <abw@wardley.org>
+#
+# COPYRIGHT
+# Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved.
+# Copyright (C) 1998-2000 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.
+#
+#----------------------------------------------------------------------------
+#
+# $Id: Stash.pm,v 2.78 2003/07/24 12:13:32 abw Exp $
+#
+#============================================================================
+
+package Template::Stash;
+
+require 5.004;
+
+use strict;
+use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS );
+
+$VERSION = sprintf("%d.%02d", q$Revision: 2.78 $ =~ /(\d+)\.(\d+)/);
+
+
+#========================================================================
+# -- PACKAGE VARIABLES AND SUBS --
+#========================================================================
+
+#------------------------------------------------------------------------
+# Definitions of various pseudo-methods. ROOT_OPS are merged into all
+# new Template::Stash objects, and are thus default global functions.
+# SCALAR_OPS are methods that can be called on a scalar, and ditto
+# respectively for LIST_OPS and HASH_OPS
+#------------------------------------------------------------------------
+
+$ROOT_OPS = {
+ 'inc' => sub { local $^W = 0; my $item = shift; ++$item },
+ 'dec' => sub { local $^W = 0; my $item = shift; --$item },
+# import => \&hash_import,
+ defined $ROOT_OPS ? %$ROOT_OPS : (),
+};
+
+$SCALAR_OPS = {
+ 'item' => sub { $_[0] },
+ 'list' => sub { [ $_[0] ] },
+ 'hash' => sub { { value => $_[0] } },
+ 'length' => sub { length $_[0] },
+ 'size' => sub { return 1 },
+ 'defined' => sub { return 1 },
+ 'repeat' => sub {
+ my ($str, $count) = @_;
+ $str = '' unless defined $str;
+ $count ||= 1;
+ return $str x $count;
+ },
+ 'search' => sub {
+ my ($str, $pattern) = @_;
+ return $str unless defined $str and defined $pattern;
+ return $str =~ /$pattern/;
+ },
+ 'replace' => sub {
+ my ($str, $search, $replace) = @_;
+ $replace = '' unless defined $replace;
+ return $str unless defined $str and defined $search;
+ $str =~ s/$search/$replace/g;
+# print STDERR "s [ $search ] [ $replace ] g\n";
+# eval "\$str =~ s$search$replaceg";
+ return $str;
+ },
+ 'match' => sub {
+ my ($str, $search) = @_;
+ return $str unless defined $str and defined $search;
+ my @matches = ($str =~ /$search/);
+ return @matches ? \@matches : '';
+ },
+ 'split' => sub {
+ my ($str, $split, @args) = @_;
+ $str = '' unless defined $str;
+ return [ defined $split ? split($split, $str, @args)
+ : split(' ', $str, @args) ];
+ },
+ 'chunk' => sub {
+ my ($string, $size) = @_;
+ my @list;
+ $size ||= 1;
+ if ($size < 0) {
+ # sexeger! It's faster to reverse the string, search
+ # it from the front and then reverse the output than to
+ # search it from the end, believe it nor not!
+ $string = reverse $string;
+ $size = -$size;
+ unshift(@list, scalar reverse $1)
+ while ($string =~ /((.{$size})|(.+))/g);
+ }
+ else {
+ push(@list, $1) while ($string =~ /((.{$size})|(.+))/g);
+ }
+ return \@list;
+ },
+
+
+ defined $SCALAR_OPS ? %$SCALAR_OPS : (),
+};
+
+$HASH_OPS = {
+ 'item' => sub { my ($hash, $item) = @_;
+ $item = '' unless defined $item;
+ $hash->{ $item };
+ },
+ 'hash' => sub { $_[0] },
+ 'size' => sub { scalar keys %{$_[0]} },
+ 'keys' => sub { [ keys %{ $_[0] } ] },
+ 'values' => sub { [ values %{ $_[0] } ] },
+ 'each' => sub { [ %{ $_[0] } ] },
+ 'list' => sub { my ($hash, $what) = @_; $what ||= '';
+ return ($what eq 'keys') ? [ keys %$hash ]
+ : ($what eq 'values') ? [ values %$hash ]
+ : ($what eq 'each') ? [ %$hash ]
+ : [ map { { key => $_ , value => $hash->{ $_ } } }
+ keys %$hash ];
+ },
+ 'exists' => sub { exists $_[0]->{ $_[1] } },
+ 'defined' => sub { defined $_[0]->{ $_[1] } },
+ 'import' => \&hash_import,
+ 'sort' => sub {
+ my ($hash) = @_;
+ [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ];
+ },
+ 'nsort' => sub {
+ my ($hash) = @_;
+ [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ];
+ },
+ defined $HASH_OPS ? %$HASH_OPS : (),
+};
+
+$LIST_OPS = {
+ 'item' => sub { $_[0]->[ $_[1] || 0 ] },
+ 'list' => sub { $_[0] },
+ 'hash' => sub { my $list = shift; my $n = 0;
+ return { map { ($n++, $_) } @$list }; },
+ 'push' => sub { my $list = shift; push(@$list, shift); return '' },
+ 'pop' => sub { my $list = shift; pop(@$list) },
+ 'unshift' => sub { my $list = shift; unshift(@$list, shift); return '' },
+ 'shift' => sub { my $list = shift; shift(@$list) },
+ 'max' => sub { local $^W = 0; my $list = shift; $#$list; },
+ 'size' => sub { local $^W = 0; my $list = shift; $#$list + 1; },
+ 'first' => sub {
+ my $list = shift;
+ return $list->[0] unless @_;
+ return [ @$list[0..$_[0]-1] ];
+ },
+ 'last' => sub {
+ my $list = shift;
+ return $list->[-1] unless @_;
+ return [ @$list[-$_[0]..-1] ];
+ },
+ 'reverse' => sub { my $list = shift; [ reverse @$list ] },
+ 'grep' => sub {
+ my ($list, $pattern) = @_;
+ $pattern ||= '';
+ return [ grep /$pattern/, @$list ];
+ },
+ 'join' => sub {
+ my ($list, $joint) = @_;
+ join(defined $joint ? $joint : ' ',
+ map { defined $_ ? $_ : '' } @$list)
+ },
+ 'sort' => sub {
+ $^W = 0;
+ my ($list, $field) = @_;
+ return $list unless @$list > 1; # no need to sort 1 item lists
+ return $field # Schwartzian Transform
+ ? map { $_->[0] } # for case insensitivity
+ sort { $a->[1] cmp $b->[1] }
+ map { [ $_, lc(ref($_) eq 'HASH'
+ ? $_->{ $field } :
+ UNIVERSAL::can($_, $field)
+ ? $_->$field() : $_) ] }
+ @$list
+ : map { $_->[0] }
+ sort { $a->[1] cmp $b->[1] }
+ map { [ $_, lc $_ ] }
+ @$list
+ },
+ 'nsort' => sub {
+ my ($list, $field) = @_;
+ return $list unless $#$list; # no need to sort 1 item lists
+ return $field # Schwartzian Transform
+ ? map { $_->[0] } # for case insensitivity
+ sort { $a->[1] <=> $b->[1] }
+ map { [ $_, lc(ref($_) eq 'HASH'
+ ? $_->{ $field } :
+ UNIVERSAL::can($_, $field)
+ ? $_->$field() : $_) ] }
+ @$list
+ : map { $_->[0] }
+ sort { $a->[1] <=> $b->[1] }
+ map { [ $_, lc $_ ] }
+ @$list
+ },
+ 'unique' => sub { my %u; [ grep { ++$u{$_} == 1 } @{$_[0]} ] },
+ 'merge' => sub {
+ my $list = shift;
+ return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ];
+ },
+ 'slice' => sub {
+ my ($list, $from, $to) = @_;
+ $from ||= 0;
+ $to = $#$list unless defined $to;
+ return [ @$list[$from..$to] ];
+ },
+ 'splice' => sub {
+ my ($list, $offset, $length, @replace) = @_;
+
+ if (@replace) {
+ # @replace can contain a list of multiple replace items, or
+ # be a single reference to a list
+ @replace = @{ $replace[0] }
+ if @replace == 1 && ref $replace[0] eq 'ARRAY';
+ return [ splice @$list, $offset, $length, @replace ];
+ }
+ elsif (defined $length) {
+ return [ splice @$list, $offset, $length ];
+ }
+ elsif (defined $offset) {
+ return [ splice @$list, $offset ];
+ }
+ else {
+ return [ splice(@$list) ];
+ }
+ },
+
+ defined $LIST_OPS ? %$LIST_OPS : (),
+};
+
+sub hash_import {
+ my ($hash, $imp) = @_;
+ $imp = {} unless ref $imp eq 'HASH';
+ @$hash{ keys %$imp } = values %$imp;
+ return '';
+}
+
+
+#------------------------------------------------------------------------
+# define_vmethod($type, $name, \&sub)
+#
+# Defines a virtual method of type $type (SCALAR, HASH, or LIST), with
+# name $name, that invokes &sub when called. It is expected that &sub
+# be able to handle the type that it will be called upon.
+#------------------------------------------------------------------------
+
+sub define_vmethod {
+ my ($class, $type, $name, $sub) = @_;
+ my $op;
+ $type = lc $type;
+
+ if ($type =~ /^scalar|item$/) {
+ $op = $SCALAR_OPS;
+ }
+ elsif ($type eq 'hash') {
+ $op = $HASH_OPS;
+ }
+ elsif ($type =~ /^list|array$/) {
+ $op = $LIST_OPS;
+ }
+ else {
+ die "invalid vmethod type: $type\n";
+ }
+
+ $op->{ $name } = $sub;
+
+ return 1;
+}
+
+
+#========================================================================
+# ----- 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,
+ };
+
+ 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) {
+ $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;
+}
+
+
+#------------------------------------------------------------------------
+# undefined($ident, $args)
+#
+# Method called when a get() returns an undefined value. Can be redefined
+# in a subclass to implement alternate handling.
+#------------------------------------------------------------------------
+
+sub undefined {
+ my ($self, $ident, $args);
+ return '';
+}
+
+
+#========================================================================
+# ----- PRIVATE OBJECT METHODS -----
+#========================================================================
+
+#------------------------------------------------------------------------
+# _dotop($root, $item, \@args, $lvalue)
+#
+# 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) = @_;
+ my $rootref = ref $root;
+ my $atroot = ($root eq $self);
+ my ($value, @result);
+
+ $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 ($atroot || $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 })) {
+ return $value unless ref $value eq 'CODE'; ## RETURN
+ @result = &$value(@$args); ## @result
+ }
+ elsif ($lvalue) {
+ # we create an intermediate hash if this is an lvalue
+ return $root->{ $item } = { }; ## RETURN
+ }
+ # ugly hack: only allow import vmeth to be called on root stash
+ elsif (($value = $HASH_OPS->{ $item })
+ && ! $atroot || $item eq 'import') {
+ @result = &$value($root, @$args); ## @result
+ }
+ elsif ( ref $item eq 'ARRAY' ) {
+ # hash slice
+ return [@$root{@$item}]; ## RETURN
+ }
+ }
+ 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 ($item =~ /^-?\d+$/) {
+ $value = $root->[$item];
+ return $value unless ref $value eq 'CODE'; ## RETURN
+ @result = &$value(@$args); ## @result
+ }
+ 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.
+ eval { @result = $root->$item(@$args); };
+
+ if ($@) {
+ # temporary hack - required to propogate errors thrown
+ # by views; if $@ is a ref (e.g. Template::Exception
+ # object then we assume it's a real error that needs
+ # real throwing
+
+ die $@ if ref($@) || ($@ !~ /Can't locate object method/);
+
+ # failed to call object method, so try some fallbacks
+ if (UNIVERSAL::isa($root, 'HASH')
+ && defined($value = $root->{ $item })) {
+ return $value unless ref $value eq 'CODE'; ## RETURN
+ @result = &$value(@$args);
+ }
+ elsif (UNIVERSAL::isa($root, 'ARRAY')
+ && ($value = $LIST_OPS->{ $item })) {
+ @result = &$value($root, @$args);
+ }
+ elsif ($value = $SCALAR_OPS->{ $item }) {
+ @result = &$value($root, @$args);
+ }
+ elsif ($value = $LIST_OPS->{ $item }) {
+ @result = &$value([$root], @$args);
+ }
+ elsif ($self->{ _DEBUG }) {
+ @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 (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
+ # last-ditch: can we promote a scalar to a one-element
+ # list and apply a LIST_OPS virtual method?
+ @result = &$value([$root], @$args);
+ }
+ 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 ## RETURN
+ scalar @result > 1 ? [ @result ] : $result[0];
+ }
+ elsif (defined $result[1]) {
+ die $result[1]; ## DIE
+ }
+ elsif ($self->{ _DEBUG }) {
+ die "$item is undefined\n"; ## DIE
+ }
+
+ return undef;
+}
+
+
+#------------------------------------------------------------------------
+# _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 $atroot = ($root eq $self);
+ 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' || $atroot) {
+# if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) {
+# # import hash entries into root hash
+# @$root{ keys %$value } = values %$value;
+# return ''; ## RETURN
+# }
+ # 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
+ unless $default && $root->$item();
+
+# 2 issues:
+# - method call should be wrapped in eval { }
+# - fallback on hash methods if object method not found
+#
+# eval { $result = $root->$item(@$args, $value); };
+#
+# if ($@) {
+# die $@ if ref($@) || ($@ !~ /Can't locate object method/);
+#
+# # failed to call object method, so try some fallbacks
+# if (UNIVERSAL::isa($root, 'HASH') && exists $root->{ $item }) {
+# $result = ($root->{ $item } = $value)
+# unless $default && $root->{ $item };
+# }
+# }
+# return $result; ## 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;
+ return "[Template::Stash] " . $self->_dump_frame(2);
+}
+
+sub _dump_frame {
+ my ($self, $indent) = @_;
+ $indent ||= 1;
+ my $buffer = ' ';
+ my $pad = $buffer x $indent;
+ my $text = "{\n";
+ 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;
+ next if $key =~ /^\./;
+ if (ref($value) eq 'ARRAY') {
+ $value = '[ ' . join(', ', map { defined $_ ? $_ : '<undef>' }
+ @$value) . ' ]';
+ }
+ elsif (ref $value eq 'HASH') {
+ $value = _dump_frame($value, $indent + 1);
+ }
+
+ $text .= sprintf("$pad%-16s => $value\n", $key);
+ }
+ $text .= $buffer x ($indent - 1) . '}';
+ return $text;
+}
+
+
+1;
+
+__END__
+
+
+#------------------------------------------------------------------------
+# IMPORTANT NOTE
+# This documentation is generated automatically from source
+# templates. Any changes you make here may be lost.
+#
+# The 'docsrc' documentation source bundle is available for download
+# from http://www.template-toolkit.org/docs.html and contains all
+# the source templates, XML files, scripts, etc., from which the
+# documentation for the Template Toolkit is built.
+#------------------------------------------------------------------------
+
+=head1 NAME
+
+Template::Stash - Magical storage for template variables
+
+=head1 SYNOPSIS
+
+ use Template::Stash;
+
+ my $stash = Template::Stash->new(\%vars);
+
+ # get variable values
+ $value = $stash->get($variable);
+ $value = $stash->get(\@compound);
+
+ # set variable value
+ $stash->set($variable, $value);
+ $stash->set(\@compound, $value);
+
+ # default variable value
+ $stash->set($variable, $value, 1);
+ $stash->set(\@compound, $value, 1);
+
+ # set variable values en masse
+ $stash->update(\%new_vars)
+
+ # methods for (de-)localising variables
+ $stash = $stash->clone(\%new_vars);
+ $stash = $stash->declone();
+
+=head1 DESCRIPTION
+
+The Template::Stash module defines an object class which is used to store
+variable values for the runtime use of the template processor. Variable
+values are stored internally in a hash reference (which itself is blessed
+to create the object) and are accessible via the get() and set() methods.
+
+Variables may reference hash arrays, lists, subroutines and objects
+as well as simple values. The stash automatically performs the right
+magic when dealing with variables, calling code or object methods,
+indexing into lists, hashes, etc.
+
+The stash has clone() and declone() methods which are used by the
+template processor to make temporary copies of the stash for
+localising changes made to variables.
+
+=head1 PUBLIC METHODS
+
+=head2 new(\%params)
+
+The new() constructor method creates and returns a reference to a new
+Template::Stash object.
+
+ my $stash = Template::Stash->new();
+
+A hash reference may be passed to provide variables and values which
+should be used to initialise the stash.
+
+ my $stash = Template::Stash->new({ var1 => 'value1',
+ var2 => 'value2' });
+
+=head2 get($variable)
+
+The get() method retrieves the variable named by the first parameter.
+
+ $value = $stash->get('var1');
+
+Dotted compound variables can be retrieved by specifying the variable
+elements by reference to a list. Each node in the variable occupies
+two entries in the list. The first gives the name of the variable
+element, the second is a reference to a list of arguments for that
+element, or 0 if none.
+
+ [% foo.bar(10).baz(20) %]
+
+ $stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]);
+
+=head2 set($variable, $value, $default)
+
+The set() method sets the variable name in the first parameter to the
+value specified in the second.
+
+ $stash->set('var1', 'value1');
+
+If the third parameter evaluates to a true value, the variable is
+set only if it did not have a true value before.
+
+ $stash->set('var2', 'default_value', 1);
+
+Dotted compound variables may be specified as per get() above.
+
+ [% foo.bar = 30 %]
+
+ $stash->set([ 'foo', 0, 'bar', 0 ], 30);
+
+The magical variable 'IMPORT' can be specified whose corresponding
+value should be a hash reference. The contents of the hash array are
+copied (i.e. imported) into the current namespace.
+
+ # foo.bar = baz, foo.wiz = waz
+ $stash->set('foo', { 'bar' => 'baz', 'wiz' => 'waz' });
+
+ # import 'foo' into main namespace: foo = baz, wiz = waz
+ $stash->set('IMPORT', $stash->get('foo'));
+
+=head2 clone(\%params)
+
+The clone() method creates and returns a new Template::Stash object which
+represents a localised copy of the parent stash. Variables can be
+freely updated in the cloned stash and when declone() is called, the
+original stash is returned with all its members intact and in the
+same state as they were before clone() was called.
+
+For convenience, a hash of parameters may be passed into clone() which
+is used to update any simple variable (i.e. those that don't contain any
+namespace elements like 'foo' and 'bar' but not 'foo.bar') variables while
+cloning the stash. For adding and updating complex variables, the set()
+method should be used after calling clone(). This will correctly resolve
+and/or create any necessary namespace hashes.
+
+A cloned stash maintains a reference to the stash that it was copied
+from in its '_PARENT' member.
+
+=head2 declone()
+
+The declone() method returns the '_PARENT' reference and can be used to
+restore the state of a stash as described above.
+
+=head1 AUTHOR
+
+Andy Wardley E<lt>abw@andywardley.comE<gt>
+
+L<http://www.andywardley.com/|http://www.andywardley.com/>
+
+
+
+
+=head1 VERSION
+
+2.78, distributed as part of the
+Template Toolkit version 2.10, released on 24 July 2003.
+
+=head1 COPYRIGHT
+
+ Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved.
+ Copyright (C) 1998-2002 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.
+
+=head1 SEE ALSO
+
+L<Template|Template>, L<Template::Context|Template::Context>
generated by cgit v1.2.3 (git 2.25.1) at 2025-08-10 03:53:14 +0000