← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/bin/epoll_server.pl
  Run on Wed Jan 5 05:34:33 2011
Reported on Wed Jan 5 05:41:35 2011

File /usr/lib/perl5/vendor_perl/5.10.1/i386-linux-thread-multi/Template/Stash.pm
Statements Executed 27574
Statement Execution Time 262ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
172821144ms144msTemplate::Stash::::cloneTemplate::Stash::clone
340410856.0ms56.0msTemplate::Stash::::undefinedTemplate::Stash::undefined
17282120.9ms20.9msTemplate::Stash::::decloneTemplate::Stash::declone
11110.9ms12.3msTemplate::Stash::::BEGIN@24Template::Stash::BEGIN@24
1011198µs198µsTemplate::Stash::::updateTemplate::Stash::update
411116µs116µsTemplate::Stash::::newTemplate::Stash::new
11154µs66µsTemplate::Stash::::BEGIN@22Template::Stash::BEGIN@22
11142µs48µsTemplate::Stash::::BEGIN@25Template::Stash::BEGIN@25
11131µs256µsTemplate::Stash::::BEGIN@26Template::Stash::BEGIN@26
11130µs81µsTemplate::Stash::::BEGIN@23Template::Stash::BEGIN@23
11218µs18µsTemplate::Stash::::CORE:qrTemplate::Stash::CORE:qr (opcode)
0000s0sTemplate::Stash::::__ANON__[:318]Template::Stash::__ANON__[:318]
0000s0sTemplate::Stash::::__ANON__[:321]Template::Stash::__ANON__[:321]
0000s0sTemplate::Stash::::_assignTemplate::Stash::_assign
0000s0sTemplate::Stash::::_dotopTemplate::Stash::_dotop
0000s0sTemplate::Stash::::_dumpTemplate::Stash::_dump
0000s0sTemplate::Stash::::_dump_frameTemplate::Stash::_dump_frame
0000s0sTemplate::Stash::::_reconstruct_identTemplate::Stash::_reconstruct_ident
0000s0sTemplate::Stash::::define_vmethodTemplate::Stash::define_vmethod
0000s0sTemplate::Stash::::getTemplate::Stash::get
0000s0sTemplate::Stash::::getrefTemplate::Stash::getref
0000s0sTemplate::Stash::::setTemplate::Stash::set
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#============================================================= -*-Perl-*-
2#
3# Template::Stash
4#
5# DESCRIPTION
6# Definition of an object class which stores and manages access to
7# variables for the Template Toolkit.
8#
9# AUTHOR
10# Andy Wardley <abw@wardley.org>
11#
12# COPYRIGHT
13# Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
14#
15# This module is free software; you can redistribute it and/or
16# modify it under the same terms as Perl itself.
17#
18#============================================================================
19
20package Template::Stash;
21
22383µs278µs
# spent 66µs (54+12) within Template::Stash::BEGIN@22 which was called # once (54µs+12µs) by Template::Stash::XS::BEGIN@17 at line 22
use strict;
# spent 66µs making 1 call to Template::Stash::BEGIN@22 # spent 12µs making 1 call to strict::import
23382µs2132µs
# spent 81µs (30+51) within Template::Stash::BEGIN@23 which was called # once (30µs+51µs) by Template::Stash::XS::BEGIN@17 at line 23
use warnings;
# spent 81µs making 1 call to Template::Stash::BEGIN@23 # spent 51µs making 1 call to warnings::import
243755µs212.4ms
# spent 12.3ms (10.9+1.45) within Template::Stash::BEGIN@24 which was called # once (10.9ms+1.45ms) by Template::Stash::XS::BEGIN@17 at line 24
use Template::VMethods;
# spent 12.3ms making 1 call to Template::Stash::BEGIN@24 # spent 9µs making 1 call to UNIVERSAL::import
253154µs254µs
# spent 48µs (42+6) within Template::Stash::BEGIN@25 which was called # once (42µs+6µs) by Template::Stash::XS::BEGIN@17 at line 25
use Template::Exception;
# spent 48µs making 1 call to Template::Stash::BEGIN@25 # spent 6µs making 1 call to UNIVERSAL::import
2638.30ms2482µs
# spent 256µs (31+226) within Template::Stash::BEGIN@26 which was called # once (31µs+226µs) by Template::Stash::XS::BEGIN@17 at line 26
use Scalar::Util qw( blessed reftype );
# spent 256µs making 1 call to Template::Stash::BEGIN@26 # spent 226µs making 1 call to Exporter::import
27
2812µsour $VERSION = 2.91;
2912µsour $DEBUG = 0 unless defined $DEBUG;
30141µs118µsour $PRIVATE = qr/^[_.]/;
# spent 18µs making 1 call to Template::Stash::CORE:qr
3112µsour $UNDEF_TYPE = 'var.undef';
3212µsour $UNDEF_INFO = 'undefined variable: %s';
33
34# alias _dotop() to dotop() so that we have a consistent method name
35# between the Perl and XS stash implementations
3615µs*dotop = \&_dotop;
37
38
39#------------------------------------------------------------------------
40# Virtual Methods
41#
42# If any of $ROOT_OPS, $SCALAR_OPS, $HASH_OPS or $LIST_OPS are already
43# defined then we merge their contents with the default virtual methods
44# define by Template::VMethods. Otherwise we can directly alias the
45# corresponding Template::VMethod package vars.
46#------------------------------------------------------------------------
47
48our $ROOT_OPS = defined $ROOT_OPS
4912µs ? { %{$Template::VMethods::ROOT_VMETHODS}, %$ROOT_OPS }
50 : $Template::VMethods::ROOT_VMETHODS;
51
52our $SCALAR_OPS = defined $SCALAR_OPS
5312µs ? { %{$Template::VMethods::TEXT_VMETHODS}, %$SCALAR_OPS }
54 : $Template::VMethods::TEXT_VMETHODS;
55
56our $HASH_OPS = defined $HASH_OPS
5712µs ? { %{$Template::VMethods::HASH_VMETHODS}, %$HASH_OPS }
58 : $Template::VMethods::HASH_VMETHODS;
59
60our $LIST_OPS = defined $LIST_OPS
6112µs ? { %{$Template::VMethods::LIST_VMETHODS}, %$LIST_OPS }
62 : $Template::VMethods::LIST_VMETHODS;
63
64
65#------------------------------------------------------------------------
66# define_vmethod($type, $name, \&sub)
67#
68# Defines a virtual method of type $type (SCALAR, HASH, or LIST), with
69# name $name, that invokes &sub when called. It is expected that &sub
70# be able to handle the type that it will be called upon.
71#------------------------------------------------------------------------
72
73sub define_vmethod {
74 my ($class, $type, $name, $sub) = @_;
75 my $op;
76 $type = lc $type;
77
78 if ($type =~ /^scalar|item$/) {
79 $op = $SCALAR_OPS;
80 }
81 elsif ($type eq 'hash') {
82 $op = $HASH_OPS;
83 }
84 elsif ($type =~ /^list|array$/) {
85 $op = $LIST_OPS;
86 }
87 else {
88 die "invalid vmethod type: $type\n";
89 }
90
91 $op->{ $name } = $sub;
92
93 return 1;
94}
95
96
97#========================================================================
98# ----- CLASS METHODS -----
99#========================================================================
100
101#------------------------------------------------------------------------
102# new(\%params)
103#
104# Constructor method which creates a new Template::Stash object.
105# An optional hash reference may be passed containing variable
106# definitions that will be used to initialise the stash.
107#
108# Returns a reference to a newly created Template::Stash.
109#------------------------------------------------------------------------
110
111
# spent 116µs within Template::Stash::new which was called 4 times, avg 29µs/call: # 4 times (116µs+0s) by Template::Config::stash at line 195 of Template/Config.pm, avg 29µs/call
sub new {
11249µs my $class = shift;
113412µs my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
114
115448µs my $self = {
116 global => { },
117 %$params,
118 %$ROOT_OPS,
119 '_PARENT' => undef,
120 };
121
122457µs bless $self, $class;
123}
124
125
126#========================================================================
127# ----- PUBLIC OBJECT METHODS -----
128#========================================================================
129
130#------------------------------------------------------------------------
131# clone(\%params)
132#
133# Creates a copy of the current stash object to effect localisation
134# of variables. The new stash is blessed into the same class as the
135# parent (which may be a derived class) and has a '_PARENT' member added
136# which contains a reference to the parent stash that created it
137# ($self). This member is used in a successive declone() method call to
138# return the reference to the parent.
139#
140# A parameter may be provided which should reference a hash of
141# variable/values which should be defined in the new stash. The
142# update() method is called to define these new variables in the cloned
143# stash.
144#
145# Returns a reference to a cloned Template::Stash.
146#------------------------------------------------------------------------
147
148
# spent 144ms within Template::Stash::clone which was called 1728 times, avg 83µs/call: # 1724 times (143ms+0s) by Template::Context::localise at line 567 of Template/Context.pm, avg 83µs/call # 4 times (385µs+0s) by Template::Context::process at line 312 of Template/Context.pm, avg 96µs/call
sub clone {
14917286.08ms my ($self, $params) = @_;
15017283.36ms $params ||= { };
151
152 # look out for magical 'import' argument which imports another hash
15317285.02ms my $import = $params->{ import };
15417288.28ms if (defined $import && ref $import eq 'HASH') {
155 delete $params->{ import };
156 }
157 else {
15817285.47ms undef $import;
159 }
160
161172898.6ms my $clone = bless {
162 %$self, # copy all parent members
163 %$params, # copy all new data
164 '_PARENT' => $self, # link to parent
165 }, ref $self;
166
167 # perform hash import if defined
16817283.83ms &{ $HASH_OPS->{ import } }($clone, $import)
169 if defined $import;
170
171172822.7ms return $clone;
172}
173
174
175#------------------------------------------------------------------------
176# declone($export)
177#
178# Returns a reference to the PARENT stash. When called in the following
179# manner:
180# $stash = $stash->declone();
181# the reference count on the current stash will drop to 0 and be "freed"
182# and the caller will be left with a reference to the parent. This
183# contains the state of the stash before it was cloned.
184#------------------------------------------------------------------------
185
186
# spent 20.9ms within Template::Stash::declone which was called 1728 times, avg 12µs/call: # 1724 times (20.8ms+0s) by Template::Context::delocalise at line 572 of Template/Context.pm, avg 12µs/call # 4 times (28µs+0s) by Template::Context::process at line 380 of Template/Context.pm, avg 7µs/call
sub declone {
18717284.49ms my $self = shift;
188172824.4ms $self->{ _PARENT } || $self;
189}
190
191
192#------------------------------------------------------------------------
193# get($ident)
194#
195# Returns the value for an variable stored in the stash. The variable
196# may be specified as a simple string, e.g. 'foo', or as an array
197# reference representing compound variables. In the latter case, each
198# pair of successive elements in the list represent a node in the
199# compound variable. The first is the variable name, the second a
200# list reference of arguments or 0 if undefined. So, the compound
201# variable [% foo.bar('foo').baz %] would be represented as the list
202# [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the
203# identifier or an empty string if undefined. Errors are thrown via
204# die().
205#------------------------------------------------------------------------
206
207sub get {
208 my ($self, $ident, $args) = @_;
209 my ($root, $result);
210 $root = $self;
211
212 if (ref $ident eq 'ARRAY'
213 || ($ident =~ /\./)
214 && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) {
215 my $size = $#$ident;
216
217 # if $ident is a list reference, then we evaluate each item in the
218 # identifier against the previous result, using the root stash
219 # ($self) as the first implicit 'result'...
220
221 foreach (my $i = 0; $i <= $size; $i += 2) {
222 $result = $self->_dotop($root, @$ident[$i, $i+1]);
223 last unless defined $result;
224 $root = $result;
225 }
226 }
227 else {
228 $result = $self->_dotop($root, $ident, $args);
229 }
230
231 return defined $result
232 ? $result
233 : $self->undefined($ident, $args);
234}
235
236
237#------------------------------------------------------------------------
238# set($ident, $value, $default)
239#
240# Updates the value for a variable in the stash. The first parameter
241# should be the variable name or array, as per get(). The second
242# parameter should be the intended value for the variable. The third,
243# optional parameter is a flag which may be set to indicate 'default'
244# mode. When set true, the variable will only be updated if it is
245# currently undefined or has a false value. The magical 'IMPORT'
246# variable identifier may be used to indicate that $value is a hash
247# reference whose values should be imported. Returns the value set,
248# or an empty string if not set (e.g. default mode). In the case of
249# IMPORT, returns the number of items imported from the hash.
250#------------------------------------------------------------------------
251
252sub set {
253 my ($self, $ident, $value, $default) = @_;
254 my ($root, $result, $error);
255
256 $root = $self;
257
258 ELEMENT: {
259 if (ref $ident eq 'ARRAY'
260 || ($ident =~ /\./)
261 && ($ident = [ map { s/\(.*$//; ($_, 0) }
262 split(/\./, $ident) ])) {
263
264 # a compound identifier may contain multiple elements (e.g.
265 # foo.bar.baz) and we must first resolve all but the last,
266 # using _dotop() with the $lvalue flag set which will create
267 # intermediate hashes if necessary...
268 my $size = $#$ident;
269 foreach (my $i = 0; $i < $size - 2; $i += 2) {
270 $result = $self->_dotop($root, @$ident[$i, $i+1], 1);
271 last ELEMENT unless defined $result;
272 $root = $result;
273 }
274
275 # then we call _assign() to assign the value to the last element
276 $result = $self->_assign($root, @$ident[$size-1, $size],
277 $value, $default);
278 }
279 else {
280 $result = $self->_assign($root, $ident, 0, $value, $default);
281 }
282 }
283
284 return defined $result ? $result : '';
285}
286
287
288#------------------------------------------------------------------------
289# getref($ident)
290#
291# Returns a "reference" to a particular item. This is represented as a
292# closure which will return the actual stash item when called.
293# WARNING: still experimental!
294#------------------------------------------------------------------------
295
296sub getref {
297 my ($self, $ident, $args) = @_;
298 my ($root, $item, $result);
299 $root = $self;
300
301 if (ref $ident eq 'ARRAY') {
302 my $size = $#$ident;
303
304 foreach (my $i = 0; $i <= $size; $i += 2) {
305 ($item, $args) = @$ident[$i, $i + 1];
306 last if $i >= $size - 2; # don't evaluate last node
307 last unless defined
308 ($root = $self->_dotop($root, $item, $args));
309 }
310 }
311 else {
312 $item = $ident;
313 }
314
315 if (defined $root) {
316 return sub { my @args = (@{$args||[]}, @_);
317 $self->_dotop($root, $item, \@args);
318 }
319 }
320 else {
321 return sub { '' };
322 }
323}
324
325
326
327
328#------------------------------------------------------------------------
329# update(\%params)
330#
331# Update multiple variables en masse. No magic is performed. Simple
332# variable names only.
333#------------------------------------------------------------------------
334
335
# spent 198µs within Template::Stash::update which was called 10 times, avg 20µs/call: # 10 times (198µs+0s) by Template::Context::process at line 317 of Template/Context.pm, avg 20µs/call
sub update {
3361021µs my ($self, $params) = @_;
337
338 # look out for magical 'import' argument to import another hash
3391020µs my $import = $params->{ import };
3401069µs if (defined $import && ref $import eq 'HASH') {
341 @$self{ keys %$import } = values %$import;
342 delete $params->{ import };
343 }
344
34510114µs @$self{ keys %$params } = values %$params;
346}
347
348
349#------------------------------------------------------------------------
350# undefined($ident, $args)
351#
352# Method called when a get() returns an undefined value. Can be redefined
353# in a subclass to implement alternate handling.
354#------------------------------------------------------------------------
355
356
# spent 56.0ms within Template::Stash::undefined which was called 3404 times, avg 16µs/call: # 1692 times (26.2ms+0s) by Template::Stash::XS::get at line 1 of Epoll/root/templates/includes/loc.tt, avg 15µs/call # 836 times (15.6ms+0s) by Template::Stash::XS::get at line 77 of Epoll/root/templates/admin/voters.tt, avg 19µs/call # 836 times (13.6ms+0s) by Template::Stash::XS::get at line 70 of Epoll/root/templates/admin/voters.tt, avg 16µs/call # 27 times (386µs+0s) by Template::Stash::XS::get at line 1 of Epoll/root/mail/includes/loc.tt, avg 14µs/call # 4 times (45µs+0s) by Template::Stash::XS::get at line 323 of Template/Context.pm, avg 11µs/call # 3 times (93µs+0s) by Template::Stash::XS::get at line 23 of Epoll/root/mail/voting_passwd.tt, avg 31µs/call # 3 times (50µs+0s) by Template::Stash::XS::get at line 27 of Epoll/root/mail/voting_passwd.tt, avg 17µs/call # once (15µs+0s) by Template::Stash::XS::get at line 24 of Epoll/root/templates/includes/header.tt # once (14µs+0s) by Template::Stash::XS::get at line 12 of Epoll/root/templates/includes/footer.tt # once (7µs+0s) by Template::Stash::XS::get at line 3 of Epoll/root/templates/includes/locale_select.tt
sub undefined {
357340414.3ms my ($self, $ident, $args) = @_;
358
359340411.4ms if ($self->{ _STRICT }) {
360 # Sorry, but we can't provide a sensible source file and line without
361 # re-designing the whole architecure of TT (see TT3)
362 die Template::Exception->new(
363 $UNDEF_TYPE,
364 sprintf(
365 $UNDEF_INFO,
366 $self->_reconstruct_ident($ident)
367 )
368 ) if $self->{ _STRICT };
369 }
370 else {
371 # There was a time when I thought this was a good idea. But it's not.
372340444.2ms return '';
373 }
374}
375
376sub _reconstruct_ident {
377 my ($self, $ident) = @_;
378 my ($name, $args, @output);
379 my @input = ref $ident eq 'ARRAY' ? @$ident : ($ident);
380
381 while (@input) {
382 $name = shift @input;
383 $args = shift @input || 0;
384 $name .= '(' . join(', ', map { /^\d+$/ ? $_ : "'$_'" } @$args) . ')'
385 if $args && ref $args eq 'ARRAY';
386 push(@output, $name);
387 }
388
389 return join('.', @output);
390}
391
392
393#========================================================================
394# ----- PRIVATE OBJECT METHODS -----
395#========================================================================
396
397#------------------------------------------------------------------------
398# _dotop($root, $item, \@args, $lvalue)
399#
400# This is the core 'dot' operation method which evaluates elements of
401# variables against their root. All variables have an implicit root
402# which is the stash object itself (a hash). Thus, a non-compound
403# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is
404# '(stash.)foo.bar'. The first parameter is a reference to the current
405# root, initially the stash itself. The second parameter contains the
406# name of the variable element, e.g. 'foo'. The third optional
407# parameter is a reference to a list of any parenthesised arguments
408# specified for the variable, which are passed to sub-routines, object
409# methods, etc. The final parameter is an optional flag to indicate
410# if this variable is being evaluated on the left side of an assignment
411# (e.g. foo.bar.baz = 10). When set true, intermediated hashes will
412# be created (e.g. bar) if necessary.
413#
414# Returns the result of evaluating the item against the root, having
415# performed any variable "magic". The value returned can then be used
416# as the root of the next _dotop() in a compound sequence. Returns
417# undef if the variable is undefined.
418#------------------------------------------------------------------------
419
420sub _dotop {
421 my ($self, $root, $item, $args, $lvalue) = @_;
422 my $rootref = ref $root;
423 my $atroot = (blessed $root && $root->isa(ref $self));
424 my ($value, @result);
425
426 $args ||= [ ];
427 $lvalue ||= 0;
428
429# print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n"
430# if $DEBUG;
431
432 # return undef without an error if either side of the dot is unviable
433 return undef unless defined($root) and defined($item);
434
435 # or if an attempt is made to access a private member, starting _ or .
436 return undef if $PRIVATE && $item =~ /$PRIVATE/;
437
438 if ($atroot || $rootref eq 'HASH') {
439 # if $root is a regular HASH or a Template::Stash kinda HASH (the
440 # *real* root of everything). We first lookup the named key
441 # in the hash, or create an empty hash in its place if undefined
442 # and the $lvalue flag is set. Otherwise, we check the HASH_OPS
443 # pseudo-methods table, calling the code if found, or return undef.
444
445 if (defined($value = $root->{ $item })) {
446 return $value unless ref $value eq 'CODE'; ## RETURN
447 @result = &$value(@$args); ## @result
448 }
449 elsif ($lvalue) {
450 # we create an intermediate hash if this is an lvalue
451 return $root->{ $item } = { }; ## RETURN
452 }
453 # ugly hack: only allow import vmeth to be called on root stash
454 elsif (($value = $HASH_OPS->{ $item })
455 && ! $atroot || $item eq 'import') {
456 @result = &$value($root, @$args); ## @result
457 }
458 elsif ( ref $item eq 'ARRAY' ) {
459 # hash slice
460 return [@$root{@$item}]; ## RETURN
461 }
462 }
463 elsif ($rootref eq 'ARRAY') {
464 # if root is an ARRAY then we check for a LIST_OPS pseudo-method
465 # or return the numerical index into the array, or undef
466 if ($value = $LIST_OPS->{ $item }) {
467 @result = &$value($root, @$args); ## @result
468 }
469 elsif ($item =~ /^-?\d+$/) {
470 $value = $root->[$item];
471 return $value unless ref $value eq 'CODE'; ## RETURN
472 @result = &$value(@$args); ## @result
473 }
474 elsif ( ref $item eq 'ARRAY' ) {
475 # array slice
476 return [@$root[@$item]]; ## RETURN
477 }
478 }
479
480 # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
481 # doesn't appear to work with CGI, returning true for the first call
482 # and false for all subsequent calls.
483
484 # UPDATE: that doesn't appear to be the case any more
485
486 elsif (blessed($root) && $root->can('can')) {
487
488 # if $root is a blessed reference (i.e. inherits from the
489 # UNIVERSAL object base class) then we call the item as a method.
490 # If that fails then we try to fallback on HASH behaviour if
491 # possible.
492 eval { @result = $root->$item(@$args); };
493
494 if ($@) {
495 # temporary hack - required to propogate errors thrown
496 # by views; if $@ is a ref (e.g. Template::Exception
497 # object then we assume it's a real error that needs
498 # real throwing
499
500 my $class = ref($root) || $root;
501 die $@ if ref($@) || ($@ !~ /Can't locate object method "\Q$item\E" via package "\Q$class\E"/);
502
503 # failed to call object method, so try some fallbacks
504 if (reftype $root eq 'HASH') {
505 if( defined($value = $root->{ $item })) {
506 return $value unless ref $value eq 'CODE'; ## RETURN
507 @result = &$value(@$args);
508 }
509 elsif ($value = $HASH_OPS->{ $item }) {
510 @result = &$value($root, @$args);
511 }
512 elsif ($value = $LIST_OPS->{ $item }) {
513 @result = &$value([$root], @$args);
514 }
515 }
516 elsif (reftype $root eq 'ARRAY') {
517 if( $value = $LIST_OPS->{ $item }) {
518 @result = &$value($root, @$args);
519 }
520 elsif( $item =~ /^-?\d+$/ ) {
521 $value = $root->[$item];
522 return $value unless ref $value eq 'CODE'; ## RETURN
523 @result = &$value(@$args); ## @result
524 }
525 elsif ( ref $item eq 'ARRAY' ) {
526 # array slice
527 return [@$root[@$item]]; ## RETURN
528 }
529 }
530 elsif ($value = $SCALAR_OPS->{ $item }) {
531 @result = &$value($root, @$args);
532 }
533 elsif ($value = $LIST_OPS->{ $item }) {
534 @result = &$value([$root], @$args);
535 }
536 elsif ($self->{ _DEBUG }) {
537 @result = (undef, $@);
538 }
539 }
540 }
541 elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
542 # at this point, it doesn't look like we've got a reference to
543 # anything we know about, so we try the SCALAR_OPS pseudo-methods
544 # table (but not for l-values)
545 @result = &$value($root, @$args); ## @result
546 }
547 elsif (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
548 # last-ditch: can we promote a scalar to a one-element
549 # list and apply a LIST_OPS virtual method?
550 @result = &$value([$root], @$args);
551 }
552 elsif ($self->{ _DEBUG }) {
553 die "don't know how to access [ $root ].$item\n"; ## DIE
554 }
555 else {
556 @result = ();
557 }
558
559 # fold multiple return items into a list unless first item is undef
560 if (defined $result[0]) {
561 return ## RETURN
562 scalar @result > 1 ? [ @result ] : $result[0];
563 }
564 elsif (defined $result[1]) {
565 die $result[1]; ## DIE
566 }
567 elsif ($self->{ _DEBUG }) {
568 die "$item is undefined\n"; ## DIE
569 }
570
571 return undef;
572}
573
574
575#------------------------------------------------------------------------
576# _assign($root, $item, \@args, $value, $default)
577#
578# Similar to _dotop() above, but assigns a value to the given variable
579# instead of simply returning it. The first three parameters are the
580# root item, the item and arguments, as per _dotop(), followed by the
581# value to which the variable should be set and an optional $default
582# flag. If set true, the variable will only be set if currently false
583# (undefined/zero)
584#------------------------------------------------------------------------
585
586sub _assign {
587 my ($self, $root, $item, $args, $value, $default) = @_;
588 my $rootref = ref $root;
589 my $atroot = ($root eq $self);
590 my $result;
591 $args ||= [ ];
592 $default ||= 0;
593
594 # return undef without an error if either side of the dot is unviable
595 return undef unless $root and defined $item;
596
597 # or if an attempt is made to update a private member, starting _ or .
598 return undef if $PRIVATE && $item =~ /$PRIVATE/;
599
600 if ($rootref eq 'HASH' || $atroot) {
601 # if the root is a hash we set the named key
602 return ($root->{ $item } = $value) ## RETURN
603 unless $default && $root->{ $item };
604 }
605 elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) {
606 # or set a list item by index number
607 return ($root->[$item] = $value) ## RETURN
608 unless $default && $root->{ $item };
609 }
610 elsif (blessed($root)) {
611 # try to call the item as a method of an object
612
613 return $root->$item(@$args, $value) ## RETURN
614 unless $default && $root->$item();
615
616# 2 issues:
617# - method call should be wrapped in eval { }
618# - fallback on hash methods if object method not found
619#
620# eval { $result = $root->$item(@$args, $value); };
621#
622# if ($@) {
623# die $@ if ref($@) || ($@ !~ /Can't locate object method/);
624#
625# # failed to call object method, so try some fallbacks
626# if (UNIVERSAL::isa($root, 'HASH') && exists $root->{ $item }) {
627# $result = ($root->{ $item } = $value)
628# unless $default && $root->{ $item };
629# }
630# }
631# return $result; ## RETURN
632 }
633 else {
634 die "don't know how to assign to [$root].[$item]\n"; ## DIE
635 }
636
637 return undef;
638}
639
640
641#------------------------------------------------------------------------
642# _dump()
643#
644# Debug method which returns a string representing the internal state
645# of the object. The method calls itself recursively to dump sub-hashes.
646#------------------------------------------------------------------------
647
648sub _dump {
649 my $self = shift;
650 return "[Template::Stash] " . $self->_dump_frame(2);
651}
652
653sub _dump_frame {
654 my ($self, $indent) = @_;
655 $indent ||= 1;
656 my $buffer = ' ';
657 my $pad = $buffer x $indent;
658 my $text = "{\n";
659 local $" = ', ';
660
661 my ($key, $value);
662
663 return $text . "...excessive recursion, terminating\n"
664 if $indent > 32;
665
666 foreach $key (keys %$self) {
667 $value = $self->{ $key };
668 $value = '<undef>' unless defined $value;
669 next if $key =~ /^\./;
670 if (ref($value) eq 'ARRAY') {
671 $value = '[ ' . join(', ', map { defined $_ ? $_ : '<undef>' }
672 @$value) . ' ]';
673 }
674 elsif (ref $value eq 'HASH') {
675 $value = _dump_frame($value, $indent + 1);
676 }
677
678 $text .= sprintf("$pad%-16s => $value\n", $key);
679 }
680 $text .= $buffer x ($indent - 1) . '}';
681 return $text;
682}
683
684
685133µs1;
686
687__END__
688
689=head1 NAME
690
691Template::Stash - Magical storage for template variables
692
693=head1 SYNOPSIS
694
695 use Template::Stash;
696
697 my $stash = Template::Stash->new(\%vars);
698
699 # get variable values
700 $value = $stash->get($variable);
701 $value = $stash->get(\@compound);
702
703 # set variable value
704 $stash->set($variable, $value);
705 $stash->set(\@compound, $value);
706
707 # default variable value
708 $stash->set($variable, $value, 1);
709 $stash->set(\@compound, $value, 1);
710
711 # set variable values en masse
712 $stash->update(\%new_vars)
713
714 # methods for (de-)localising variables
715 $stash = $stash->clone(\%new_vars);
716 $stash = $stash->declone();
717
718=head1 DESCRIPTION
719
720The C<Template::Stash> module defines an object class which is used to store
721variable values for the runtime use of the template processor. Variable
722values are stored internally in a hash reference (which itself is blessed
723to create the object) and are accessible via the L<get()> and L<set()> methods.
724
725Variables may reference hash arrays, lists, subroutines and objects
726as well as simple values. The stash automatically performs the right
727magic when dealing with variables, calling code or object methods,
728indexing into lists, hashes, etc.
729
730The stash has L<clone()> and L<declone()> methods which are used by the
731template processor to make temporary copies of the stash for
732localising changes made to variables.
733
734=head1 PUBLIC METHODS
735
736=head2 new(\%params)
737
738The C<new()> constructor method creates and returns a reference to a new
739C<Template::Stash> object.
740
741 my $stash = Template::Stash->new();
742
743A hash reference may be passed to provide variables and values which
744should be used to initialise the stash.
745
746 my $stash = Template::Stash->new({ var1 => 'value1',
747 var2 => 'value2' });
748
749=head2 get($variable)
750
751The C<get()> method retrieves the variable named by the first parameter.
752
753 $value = $stash->get('var1');
754
755Dotted compound variables can be retrieved by specifying the variable
756elements by reference to a list. Each node in the variable occupies
757two entries in the list. The first gives the name of the variable
758element, the second is a reference to a list of arguments for that
759element, or C<0> if none.
760
761 [% foo.bar(10).baz(20) %]
762
763 $stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]);
764
765=head2 set($variable, $value, $default)
766
767The C<set()> method sets the variable name in the first parameter to the
768value specified in the second.
769
770 $stash->set('var1', 'value1');
771
772If the third parameter evaluates to a true value, the variable is
773set only if it did not have a true value before.
774
775 $stash->set('var2', 'default_value', 1);
776
777Dotted compound variables may be specified as per L<get()> above.
778
779 [% foo.bar = 30 %]
780
781 $stash->set([ 'foo', 0, 'bar', 0 ], 30);
782
783The magical variable 'C<IMPORT>' can be specified whose corresponding
784value should be a hash reference. The contents of the hash array are
785copied (i.e. imported) into the current namespace.
786
787 # foo.bar = baz, foo.wiz = waz
788 $stash->set('foo', { 'bar' => 'baz', 'wiz' => 'waz' });
789
790 # import 'foo' into main namespace: bar = baz, wiz = waz
791 $stash->set('IMPORT', $stash->get('foo'));
792
793=head2 clone(\%params)
794
795The C<clone()> method creates and returns a new C<Template::Stash> object
796which represents a localised copy of the parent stash. Variables can be freely
797updated in the cloned stash and when L<declone()> is called, the original stash
798is returned with all its members intact and in the same state as they were
799before C<clone()> was called.
800
801For convenience, a hash of parameters may be passed into C<clone()> which
802is used to update any simple variable (i.e. those that don't contain any
803namespace elements like C<foo> and C<bar> but not C<foo.bar>) variables while
804cloning the stash. For adding and updating complex variables, the L<set()>
805method should be used after calling C<clone().> This will correctly resolve
806and/or create any necessary namespace hashes.
807
808A cloned stash maintains a reference to the stash that it was copied
809from in its C<_PARENT> member.
810
811=head2 declone()
812
813The C<declone()> method returns the C<_PARENT> reference and can be used to
814restore the state of a stash as described above.
815
816=head1 AUTHOR
817
818Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/>
819
820=head1 COPYRIGHT
821
822Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
823
824This module is free software; you can redistribute it and/or
825modify it under the same terms as Perl itself.
826
827=head1 SEE ALSO
828
829L<Template>, L<Template::Context>
830
831=cut
832
833# Local Variables:
834# mode: perl
835# perl-indent-level: 4
836# indent-tabs-mode: nil
837# End:
838#
839# vim: expandtab shiftwidth=4:
# spent 18µs within Template::Stash::CORE:qr which was called # once (18µs+0s) by Template::Stash::XS::BEGIN@17 at line 30 of Template/Stash.pm
sub Template::Stash::CORE:qr; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.