#============================================================= -*-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-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.
#
#============================================================================
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=$#$ident;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=$#$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;}$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=$#$ident;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"/);if(reftype$root eq 'HASH'){if(defined($value=$root->{$item})){return$value unless ref$value eq 'CODE';@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';@result=&$value(@$args);}elsif(ref$item eq 'ARRAY'){return[@$root[@$item]];}}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){@result=&$value($root,@$args);}elsif(($value=$LIST_OPS->{$item})&&!$lvalue){@result=&$value([$root],@$args);}elsif($self->{_DEBUG}){die"don't know how to access [ $root ].$item\n";}else{@result=();}if(defined$result[0]){return scalar@result>1?[@result]:$result[0];}elsif(defined$result[1]){die$result[1];}elsif($self->{_DEBUG}){die"$item is undefined\n";}return undef;}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 unless$root and defined$item;return undef if$PRIVATE&&$item=~/$PRIVATE/;if($rootref eq 'HASH'||$atroot){return($root->{$item}=$value)unless$default&&$root->{$item};}elsif($rootref eq 'ARRAY'&&$item=~/^-?\d+$/){return($root->[$item]=$value)unless$default&&$root->{$item};}elsif(blessed($root)){return$root->$item(@$args,$value)unless$default&&$root->$item();}else{die"don't know how to assign to [$root].[$item]\n";}return undef;}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__
