package Template::Stash;
use strict;
use warnings;
use Template::VMethods;
use Template::Exception;
use Scalar::Util qw( blessed reftype );
our $VERSION = 2.91;
our $DEBUG = 0 unless defined $DEBUG;
our $PRIVATE = qr/^[_.]/;
our $UNDEF_TYPE = 'var.undef';
our $UNDEF_INFO = 'undefined variable: %s';
*dotop = \&_dotop;
our $ROOT_OPS = defined $ROOT_OPS
? { %{$Template::VMethods::ROOT_VMETHODS}, %$ROOT_OPS }
: $Template::VMethods::ROOT_VMETHODS;
our $SCALAR_OPS = defined $SCALAR_OPS
? { %{$Template::VMethods::TEXT_VMETHODS}, %$SCALAR_OPS }
: $Template::VMethods::TEXT_VMETHODS;
our $HASH_OPS = defined $HASH_OPS
? { %{$Template::VMethods::HASH_VMETHODS}, %$HASH_OPS }
: $Template::VMethods::HASH_VMETHODS;
our $LIST_OPS = defined $LIST_OPS
? { %{$Template::VMethods::LIST_VMETHODS}, %$LIST_OPS }
: $Template::VMethods::LIST_VMETHODS;
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;
}
sub new {
my $class = shift;
my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
my $self = {
global => { },
%$params,
%$ROOT_OPS,
'_PARENT' => undef,
};
bless $self, $class;
}
sub clone {
my ($self, $params) = @_;
$params ||= { };
my $import = $params->{ import };
if (defined $import && ref $import eq 'HASH') {
delete $params->{ import };
}
else {
undef $import;
}
my $clone = bless {
%$self, %$params, '_PARENT' => $self, }, ref $self;
&{ $HASH_OPS->{ import } }($clone, $import)
if defined $import;
return $clone;
}
sub declone {
my $self = shift;
$self->{ _PARENT } || $self;
}
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 = $
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);
}
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) ])) {
my $size = $ 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;
}
$result = $self->_assign($root, @$ident[$size-1, $size],
$value, $default);
}
else {
$result = $self->_assign($root, $ident, 0, $value, $default);
}
}
return defined $result ? $result : '';
}
sub getref {
my ($self, $ident, $args) = @_;
my ($root, $item, $result);
$root = $self;
if (ref $ident eq 'ARRAY') {
my $size = $
foreach (my $i = 0; $i <= $size; $i += 2) {
($item, $args) = @$ident[$i, $i + 1];
last if $i >= $size - 2; 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 { '' };
}
}
sub update {
my ($self, $params) = @_;
my $import = $params->{ import };
if (defined $import && ref $import eq 'HASH') {
@$self{ keys %$import } = values %$import;
delete $params->{ import };
}
@$self{ keys %$params } = values %$params;
}
sub undefined {
my ($self, $ident, $args) = @_;
if ($self->{ _STRICT }) {
die Template::Exception->new(
$UNDEF_TYPE,
sprintf(
$UNDEF_INFO,
$self->_reconstruct_ident($ident)
)
) if $self->{ _STRICT };
}
else {
return '';
}
}
sub _reconstruct_ident {
my ($self, $ident) = @_;
my ($name, $args, @output);
my @input = ref $ident eq 'ARRAY' ? @$ident : ($ident);
while (@input) {
$name = shift @input;
$args = shift @input || 0;
$name .= '(' . join(', ', map { /^\d+$/ ? $_ : "'$_'" } @$args) . ')'
if $args && ref $args eq 'ARRAY';
push(@output, $name);
}
return join('.', @output);
}
sub _dotop {
my ($self, $root, $item, $args, $lvalue) = @_;
my $rootref = ref $root;
my $atroot = (blessed $root && $root->isa(ref $self));
my ($value, @result);
$args ||= [ ];
$lvalue ||= 0;
return undef unless defined($root) and defined($item);
return undef if $PRIVATE && $item =~ /$PRIVATE/;
if ($atroot || $rootref eq 'HASH') {
if (defined($value = $root->{ $item })) {
return $value unless ref $value eq 'CODE'; @result = &$value(@$args); }
elsif ($lvalue) {
return $root->{ $item } = { }; }
elsif (($value = $HASH_OPS->{ $item })
&& ! $atroot || $item eq 'import') {
@result = &$value($root, @$args); }
elsif ( ref $item eq 'ARRAY' ) {
return [@$root{@$item}]; }
}
elsif ($rootref eq 'ARRAY') {
if ($value = $LIST_OPS->{ $item }) {
@result = &$value($root, @$args); }
elsif ($item =~ /^-?\d+$/) {
$value = $root->[$item];
return $value unless ref $value eq 'CODE'; @result = &$value(@$args); }
elsif ( ref $item eq 'ARRAY' ) {
return [@$root[@$item]]; }
}
elsif (blessed($root) && $root->can('can')) {
eval { @result = $root->$item(@$args); };
if ($@) {
my $class = ref($root) || $root;
die $@ if ref($@) || ($@ !~ /Can't locate object method "\Q$item\E" via package "\Q$class\E"/);
# failed to call object method, so try some fallbacks
if (reftype $root eq 'HASH') {
if( defined($value = $root->{ $item })) {
return $value unless ref $value eq 'CODE'; ## RETURN
@result = &$value(@$args);
}
elsif ($value = $HASH_OPS->{ $item }) {
@result = &$value($root, @$args);
}
elsif ($value = $LIST_OPS->{ $item }) {
@result = &$value([$root], @$args);
}
}
elsif (reftype $root eq 'ARRAY') {
if( $value = $LIST_OPS->{ $item }) {
@result = &$value($root, @$args);
}
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
}
}
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;
# return undef without an error if either side of the dot is unviable
return undef unless $root and defined $item;
# or if an attempt is made to update a private member, starting _ or .
return undef if $PRIVATE && $item =~ /$PRIVATE/;
if ($rootref eq 'HASH' || $atroot) {
# 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 (blessed($root)) {
# 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__
=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 C<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 L<get()> and L<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 L<clone()> and L<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 C<new()> constructor method creates and returns a reference to a new
C<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 C<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 C<0> if none.
[% foo.bar(10).baz(20) %]
$stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]);
=head2 set($variable, $value, $default)
The C<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 L<get()> above.
[% foo.bar = 30 %]
$stash->set([ 'foo', 0, 'bar', 0 ], 30);
The magical variable 'C<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: bar = baz, wiz = waz
$stash->set('IMPORT', $stash->get('foo'));
=head2 update($variables)
This method can be used to set or update several variables in one go.
$stash->update({
foo => 10,
bar => 20,
});
=head2 getref($variable)
This undocumented feature returns a closure which can be called to get the
value of a variable. It is used to implement variable references which are
evlauted lazily.
[% x = \foo.bar.baz %] # x is a reference to foo.bar.baz
[% x %] # evalautes foo.bar.baz
=head2 clone(\%params)
The C<clone()> method creates and returns a new C<Template::Stash> object
which represents a localised copy of the parent stash. Variables can be freely
updated in the cloned stash and when L<declone()> is called, the original stash
is returned with all its members intact and in the same state as they were
before C<clone()> was called.
For convenience, a hash of parameters may be passed into C<clone()> which
is used to update any simple variable (i.e. those that don't contain any
namespace elements like C<foo> and C<bar> but not C<foo.bar>) variables while
cloning the stash. For adding and updating complex variables, the L<set()>
method should be used after calling C<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 C<_PARENT> member.
=head2 declone()
The C<declone()> method returns the C<_PARENT> reference and can be used to
restore the state of a stash as described above.
=head2 define_vmethod($type, $name, $code)
This method can be used to define new virtual methods. The first argument
should be either C<scalar> or C<item> to define scalar virtual method, C<hash>
to define hash virtual methods, or either C<array> or C<list> for list virtual
methods. The second argument should be the name of the new method. The third
argument should be a reference to a subroutine implementing the method. The
data item on which the virtual method is called is passed to the subroutine as
the first argument.
$stash->define_vmethod(
item => ucfirst => sub {
my $text = shift;
return ucfirst $text
}
);
=head1 INTERNAL METHODS
=head2 dotop($root, $item, \@args, $lvalue)
This is the core C<dot> operation method which evaluates elements of
variables against their root.
=head2 undefined($ident, $args)
This method is called when L<get()> encounters an undefined value. If the
C<STRICT|Template::Manual::Config#STRICT> option is in effect then it will
throw an exception indicating the use of an undefined value. Otherwise it
will silently return an empty string.
The method can be redefined in a subclass to implement alternate handling
of undefined values.
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/>
=head1 COPYRIGHT
Copyright (C) 1996-2012 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>, L<Template::Context>
=cut