← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 14:31:06 2016
Reported on Fri Jan 8 14:31:39 2016

Filename/usr/lib/x86_64-linux-gnu/perl5/5.20/Template/Stash.pm
StatementsExecuted 159 statements in 4.12ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1113.49ms3.67msTemplate::Stash::::BEGIN@24Template::Stash::BEGIN@24
10211.12ms1.12msTemplate::Stash::::cloneTemplate::Stash::clone
1010735µs35µsTemplate::Stash::::undefinedTemplate::Stash::undefined
11123µs30µsTemplate::Stash::::BEGIN@22Template::Stash::BEGIN@22
102123µs23µsTemplate::Stash::::decloneTemplate::Stash::declone
11115µs15µsTemplate::Stash::::newTemplate::Stash::new
11112µs71µsTemplate::Stash::::BEGIN@26Template::Stash::BEGIN@26
1119µs9µsTemplate::Stash::::BEGIN@25Template::Stash::BEGIN@25
1117µs11µsTemplate::Stash::::BEGIN@23Template::Stash::BEGIN@23
1115µs5µsTemplate::Stash::::updateTemplate::Stash::update
1115µs5µsTemplate::Stash::::CORE:qrTemplate::Stash::CORE:qr (opcode)
0000s0sTemplate::Stash::::__ANON__[:317]Template::Stash::__ANON__[:317]
0000s0sTemplate::Stash::::__ANON__[:320]Template::Stash::__ANON__[:320]
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
22235µs237µs
# spent 30µs (23+7) within Template::Stash::BEGIN@22 which was called: # once (23µs+7µs) by Template::Stash::XS::BEGIN@17 at line 22
use strict;
# spent 30µs making 1 call to Template::Stash::BEGIN@22 # spent 7µs making 1 call to strict::import
23228µs215µs
# spent 11µs (7+4) within Template::Stash::BEGIN@23 which was called: # once (7µs+4µs) by Template::Stash::XS::BEGIN@17 at line 23
use warnings;
# spent 11µs making 1 call to Template::Stash::BEGIN@23 # spent 4µs making 1 call to warnings::import
242223µs13.67ms
# spent 3.67ms (3.49+180µs) within Template::Stash::BEGIN@24 which was called: # once (3.49ms+180µs) by Template::Stash::XS::BEGIN@17 at line 24
use Template::VMethods;
# spent 3.67ms making 1 call to Template::Stash::BEGIN@24
25232µs19µs
# spent 9µs within Template::Stash::BEGIN@25 which was called: # once (9µs+0s) by Template::Stash::XS::BEGIN@17 at line 25
use Template::Exception;
# spent 9µs making 1 call to Template::Stash::BEGIN@25
2622.53ms2131µs
# spent 71µs (12+60) within Template::Stash::BEGIN@26 which was called: # once (12µs+60µs) by Template::Stash::XS::BEGIN@17 at line 26
use Scalar::Util qw( blessed reftype );
# spent 71µs making 1 call to Template::Stash::BEGIN@26 # spent 60µs making 1 call to Exporter::import
27
281700nsour $VERSION = 2.91;
291800nsour $DEBUG = 0 unless defined $DEBUG;
30118µs15µsour $PRIVATE = qr/^[_.]/;
# spent 5µs making 1 call to Template::Stash::CORE:qr
311300nsour $UNDEF_TYPE = 'var.undef';
321300nsour $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
3612µ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
491400ns ? { %{$Template::VMethods::ROOT_VMETHODS}, %$ROOT_OPS }
50 : $Template::VMethods::ROOT_VMETHODS;
51
52our $SCALAR_OPS = defined $SCALAR_OPS
531300ns ? { %{$Template::VMethods::TEXT_VMETHODS}, %$SCALAR_OPS }
54 : $Template::VMethods::TEXT_VMETHODS;
55
56our $HASH_OPS = defined $HASH_OPS
571400ns ? { %{$Template::VMethods::HASH_VMETHODS}, %$HASH_OPS }
58 : $Template::VMethods::HASH_VMETHODS;
59
60our $LIST_OPS = defined $LIST_OPS
611500ns ? { %{$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 15µs within Template::Stash::new which was called: # once (15µs+0s) by Template::Config::stash at line 195 of Template/Config.pm
sub new {
1121800ns my $class = shift;
11313µs my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
114
11518µs my $self = {
116 global => { },
117 %$params,
118 %$ROOT_OPS,
119 '_PARENT' => undef,
120 };
121
12216µ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 1.12ms within Template::Stash::clone which was called 10 times, avg 112µs/call: # 9 times (1.01ms+0s) by Template::Context::process at line 312 of Template/Context.pm, avg 113µs/call # once (107µs+0s) by Template::Context::localise at line 567 of Template/Context.pm
sub clone {
149106µs my ($self, $params) = @_;
150107µs $params ||= { };
151
152 # look out for magical 'import' argument which imports another hash
153107µs my $import = $params->{ import };
154107µs if (defined $import && ref $import eq 'HASH') {
155 delete $params->{ import };
156 }
157 else {
158103µs undef $import;
159 }
160
161101.05ms 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
168105µs &{ $HASH_OPS->{ import } }($clone, $import)
169 if defined $import;
170
1711047µs 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 23µs within Template::Stash::declone which was called 10 times, avg 2µs/call: # 9 times (22µs+0s) by Template::Context::process at line 380 of Template/Context.pm, avg 2µs/call # once (1µs+0s) by Template::Context::delocalise at line 572 of Template/Context.pm
sub declone {
187104µs my $self = shift;
1881025µs $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#------------------------------------------------------------------------
294
295sub getref {
296 my ($self, $ident, $args) = @_;
297 my ($root, $item, $result);
298 $root = $self;
299
300 if (ref $ident eq 'ARRAY') {
301 my $size = $#$ident;
302
303 foreach (my $i = 0; $i <= $size; $i += 2) {
304 ($item, $args) = @$ident[$i, $i + 1];
305 last if $i >= $size - 2; # don't evaluate last node
306 last unless defined
307 ($root = $self->_dotop($root, $item, $args));
308 }
309 }
310 else {
311 $item = $ident;
312 }
313
314 if (defined $root) {
315 return sub { my @args = (@{$args||[]}, @_);
316 $self->_dotop($root, $item, \@args);
317 }
318 }
319 else {
320 return sub { '' };
321 }
322}
323
- -
327#------------------------------------------------------------------------
328# update(\%params)
329#
330# Update multiple variables en masse. No magic is performed. Simple
331# variable names only.
332#------------------------------------------------------------------------
333
334
# spent 5µs within Template::Stash::update which was called: # once (5µs+0s) by Template::Context::process at line 317 of Template/Context.pm
sub update {
3351500ns my ($self, $params) = @_;
336
337 # look out for magical 'import' argument to import another hash
33811µs my $import = $params->{ import };
3391300ns if (defined $import && ref $import eq 'HASH') {
340 @$self{ keys %$import } = values %$import;
341 delete $params->{ import };
342 }
343
34415µs @$self{ keys %$params } = values %$params;
345}
346
347
348#------------------------------------------------------------------------
349# undefined($ident, $args)
350#
351# Method called when a get() returns an undefined value. Can be redefined
352# in a subclass to implement alternate handling.
353#------------------------------------------------------------------------
354
355
# spent 35µs within Template::Stash::undefined which was called 10 times, avg 3µs/call: # once (5µs+0s) by Template::Stash::XS::get at line 24 of koha-tmpl/intranet-tmpl/prog/en/includes/doc-head-open.inc # once (5µs+0s) by Template::Stash::XS::get at line 87 of koha-tmpl/intranet-tmpl/prog/en/includes/doc-head-close.inc # once (4µs+0s) by Template::Stash::XS::get at line 80 of koha-tmpl/intranet-tmpl/prog/en/includes/header.inc # once (4µs+0s) by Template::Stash::XS::get at line 198 of koha-tmpl/intranet-tmpl/prog/en/modules/intranet-main.tt # once (4µs+0s) by Template::Stash::XS::get at line 36 of koha-tmpl/intranet-tmpl/prog/en/includes/patron-search-box.inc # once (4µs+0s) by Template::Stash::XS::get at line 12 of koha-tmpl/intranet-tmpl/prog/en/includes/doc-head-close.inc # once (4µs+0s) by Template::Stash::XS::get at line 67 of koha-tmpl/intranet-tmpl/prog/en/includes/intranet-bottom.inc # once (3µs+0s) by Template::Stash::XS::get at line 323 of Template/Context.pm # once (2µs+0s) by Template::Stash::XS::get at line 25 of koha-tmpl/intranet-tmpl/prog/en/modules/intranet-main.tt # once (1µs+0s) by Template::Stash::XS::get at line 24 of koha-tmpl/intranet-tmpl/prog/en/includes/doc-head-close.inc
sub undefined {
356108µs my ($self, $ident, $args) = @_;
357
358107µs if ($self->{ _STRICT }) {
359 # Sorry, but we can't provide a sensible source file and line without
360 # re-designing the whole architecure of TT (see TT3)
361 die Template::Exception->new(
362 $UNDEF_TYPE,
363 sprintf(
364 $UNDEF_INFO,
365 $self->_reconstruct_ident($ident)
366 )
367 ) if $self->{ _STRICT };
368 }
369 else {
370 # There was a time when I thought this was a good idea. But it's not.
3711038µs return '';
372 }
373}
374
375sub _reconstruct_ident {
376 my ($self, $ident) = @_;
377 my ($name, $args, @output);
378 my @input = ref $ident eq 'ARRAY' ? @$ident : ($ident);
379
380 while (@input) {
381 $name = shift @input;
382 $args = shift @input || 0;
383 $name .= '(' . join(', ', map { /^\d+$/ ? $_ : "'$_'" } @$args) . ')'
384 if $args && ref $args eq 'ARRAY';
385 push(@output, $name);
386 }
387
388 return join('.', @output);
389}
390
391
392#========================================================================
393# ----- PRIVATE OBJECT METHODS -----
394#========================================================================
395
396#------------------------------------------------------------------------
397# _dotop($root, $item, \@args, $lvalue)
398#
399# This is the core 'dot' operation method which evaluates elements of
400# variables against their root. All variables have an implicit root
401# which is the stash object itself (a hash). Thus, a non-compound
402# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is
403# '(stash.)foo.bar'. The first parameter is a reference to the current
404# root, initially the stash itself. The second parameter contains the
405# name of the variable element, e.g. 'foo'. The third optional
406# parameter is a reference to a list of any parenthesised arguments
407# specified for the variable, which are passed to sub-routines, object
408# methods, etc. The final parameter is an optional flag to indicate
409# if this variable is being evaluated on the left side of an assignment
410# (e.g. foo.bar.baz = 10). When set true, intermediated hashes will
411# be created (e.g. bar) if necessary.
412#
413# Returns the result of evaluating the item against the root, having
414# performed any variable "magic". The value returned can then be used
415# as the root of the next _dotop() in a compound sequence. Returns
416# undef if the variable is undefined.
417#------------------------------------------------------------------------
418
419sub _dotop {
420 my ($self, $root, $item, $args, $lvalue) = @_;
421 my $rootref = ref $root;
422 my $atroot = (blessed $root && $root->isa(ref $self));
423 my ($value, @result);
424
425 $args ||= [ ];
426 $lvalue ||= 0;
427
428# print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n"
429# if $DEBUG;
430
431 # return undef without an error if either side of the dot is unviable
432 return undef unless defined($root) and defined($item);
433
434 # or if an attempt is made to access a private member, starting _ or .
435 return undef if $PRIVATE && $item =~ /$PRIVATE/;
436
437 if ($atroot || $rootref eq 'HASH') {
438 # if $root is a regular HASH or a Template::Stash kinda HASH (the
439 # *real* root of everything). We first lookup the named key
440 # in the hash, or create an empty hash in its place if undefined
441 # and the $lvalue flag is set. Otherwise, we check the HASH_OPS
442 # pseudo-methods table, calling the code if found, or return undef.
443
444 if (defined($value = $root->{ $item })) {
445 return $value unless ref $value eq 'CODE'; ## RETURN
446 @result = &$value(@$args); ## @result
447 }
448 elsif ($lvalue) {
449 # we create an intermediate hash if this is an lvalue
450 return $root->{ $item } = { }; ## RETURN
451 }
452 # ugly hack: only allow import vmeth to be called on root stash
453 elsif (($value = $HASH_OPS->{ $item })
454 && ! $atroot || $item eq 'import') {
455 @result = &$value($root, @$args); ## @result
456 }
457 elsif ( ref $item eq 'ARRAY' ) {
458 # hash slice
459 return [@$root{@$item}]; ## RETURN
460 }
461 }
462 elsif ($rootref eq 'ARRAY') {
463 # if root is an ARRAY then we check for a LIST_OPS pseudo-method
464 # or return the numerical index into the array, or undef
465 if ($value = $LIST_OPS->{ $item }) {
466 @result = &$value($root, @$args); ## @result
467 }
468 elsif ($item =~ /^-?\d+$/) {
469 $value = $root->[$item];
470 return $value unless ref $value eq 'CODE'; ## RETURN
471 @result = &$value(@$args); ## @result
472 }
473 elsif ( ref $item eq 'ARRAY' ) {
474 # array slice
475 return [@$root[@$item]]; ## RETURN
476 }
477 }
478
479 # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
480 # doesn't appear to work with CGI, returning true for the first call
481 # and false for all subsequent calls.
482
483 # UPDATE: that doesn't appear to be the case any more
484
485 elsif (blessed($root) && $root->can('can')) {
486
487 # if $root is a blessed reference (i.e. inherits from the
488 # UNIVERSAL object base class) then we call the item as a method.
489 # If that fails then we try to fallback on HASH behaviour if
490 # possible.
491 eval { @result = $root->$item(@$args); };
492
493 if ($@) {
494 # temporary hack - required to propogate errors thrown
495 # by views; if $@ is a ref (e.g. Template::Exception
496 # object then we assume it's a real error that needs
497 # real throwing
498
499 my $class = ref($root) || $root;
500 die $@ if ref($@) || ($@ !~ /Can't locate object method "\Q$item\E" via package "\Q$class\E"/);
501
502 # failed to call object method, so try some fallbacks
503 if (reftype $root eq 'HASH') {
504 if( defined($value = $root->{ $item })) {
505 return $value unless ref $value eq 'CODE'; ## RETURN
506 @result = &$value(@$args);
507 }
508 elsif ($value = $HASH_OPS->{ $item }) {
509 @result = &$value($root, @$args);
510 }
511 elsif ($value = $LIST_OPS->{ $item }) {
512 @result = &$value([$root], @$args);
513 }
514 }
515 elsif (reftype $root eq 'ARRAY') {
516 if( $value = $LIST_OPS->{ $item }) {
517 @result = &$value($root, @$args);
518 }
519 elsif( $item =~ /^-?\d+$/ ) {
520 $value = $root->[$item];
521 return $value unless ref $value eq 'CODE'; ## RETURN
522 @result = &$value(@$args); ## @result
523 }
524 elsif ( ref $item eq 'ARRAY' ) {
525 # array slice
526 return [@$root[@$item]]; ## RETURN
527 }
528 }
529 elsif ($value = $SCALAR_OPS->{ $item }) {
530 @result = &$value($root, @$args);
531 }
532 elsif ($value = $LIST_OPS->{ $item }) {
533 @result = &$value([$root], @$args);
534 }
535 elsif ($self->{ _DEBUG }) {
536 @result = (undef, $@);
537 }
538 }
539 }
540 elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
541 # at this point, it doesn't look like we've got a reference to
542 # anything we know about, so we try the SCALAR_OPS pseudo-methods
543 # table (but not for l-values)
544 @result = &$value($root, @$args); ## @result
545 }
546 elsif (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
547 # last-ditch: can we promote a scalar to a one-element
548 # list and apply a LIST_OPS virtual method?
549 @result = &$value([$root], @$args);
550 }
551 elsif ($self->{ _DEBUG }) {
552 die "don't know how to access [ $root ].$item\n"; ## DIE
553 }
554 else {
555 @result = ();
556 }
557
558 # fold multiple return items into a list unless first item is undef
559 if (defined $result[0]) {
560 return ## RETURN
561 scalar @result > 1 ? [ @result ] : $result[0];
562 }
563 elsif (defined $result[1]) {
564 die $result[1]; ## DIE
565 }
566 elsif ($self->{ _DEBUG }) {
567 die "$item is undefined\n"; ## DIE
568 }
569
570 return undef;
571}
572
573
574#------------------------------------------------------------------------
575# _assign($root, $item, \@args, $value, $default)
576#
577# Similar to _dotop() above, but assigns a value to the given variable
578# instead of simply returning it. The first three parameters are the
579# root item, the item and arguments, as per _dotop(), followed by the
580# value to which the variable should be set and an optional $default
581# flag. If set true, the variable will only be set if currently false
582# (undefined/zero)
583#------------------------------------------------------------------------
584
585sub _assign {
586 my ($self, $root, $item, $args, $value, $default) = @_;
587 my $rootref = ref $root;
588 my $atroot = ($root eq $self);
589 my $result;
590 $args ||= [ ];
591 $default ||= 0;
592
593 # return undef without an error if either side of the dot is unviable
594 return undef unless $root and defined $item;
595
596 # or if an attempt is made to update a private member, starting _ or .
597 return undef if $PRIVATE && $item =~ /$PRIVATE/;
598
599 if ($rootref eq 'HASH' || $atroot) {
600 # if the root is a hash we set the named key
601 return ($root->{ $item } = $value) ## RETURN
602 unless $default && $root->{ $item };
603 }
604 elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) {
605 # or set a list item by index number
606 return ($root->[$item] = $value) ## RETURN
607 unless $default && $root->{ $item };
608 }
609 elsif (blessed($root)) {
610 # try to call the item as a method of an object
611
612 return $root->$item(@$args, $value) ## RETURN
613 unless $default && $root->$item();
614
615# 2 issues:
616# - method call should be wrapped in eval { }
617# - fallback on hash methods if object method not found
618#
619# eval { $result = $root->$item(@$args, $value); };
620#
621# if ($@) {
622# die $@ if ref($@) || ($@ !~ /Can't locate object method/);
623#
624# # failed to call object method, so try some fallbacks
625# if (UNIVERSAL::isa($root, 'HASH') && exists $root->{ $item }) {
626# $result = ($root->{ $item } = $value)
627# unless $default && $root->{ $item };
628# }
629# }
630# return $result; ## RETURN
631 }
632 else {
633 die "don't know how to assign to [$root].[$item]\n"; ## DIE
634 }
635
636 return undef;
637}
638
639
640#------------------------------------------------------------------------
641# _dump()
642#
643# Debug method which returns a string representing the internal state
644# of the object. The method calls itself recursively to dump sub-hashes.
645#------------------------------------------------------------------------
646
647sub _dump {
648 my $self = shift;
649 return "[Template::Stash] " . $self->_dump_frame(2);
650}
651
652sub _dump_frame {
653 my ($self, $indent) = @_;
654 $indent ||= 1;
655 my $buffer = ' ';
656 my $pad = $buffer x $indent;
657 my $text = "{\n";
658 local $" = ', ';
659
660 my ($key, $value);
661
662 return $text . "...excessive recursion, terminating\n"
663 if $indent > 32;
664
665 foreach $key (keys %$self) {
666 $value = $self->{ $key };
667 $value = '<undef>' unless defined $value;
668 next if $key =~ /^\./;
669 if (ref($value) eq 'ARRAY') {
670 $value = '[ ' . join(', ', map { defined $_ ? $_ : '<undef>' }
671 @$value) . ' ]';
672 }
673 elsif (ref $value eq 'HASH') {
674 $value = _dump_frame($value, $indent + 1);
675 }
676
677 $text .= sprintf("$pad%-16s => $value\n", $key);
678 }
679 $text .= $buffer x ($indent - 1) . '}';
680 return $text;
681}
682
683
684110µs1;
685
686__END__
 
# spent 5µs within Template::Stash::CORE:qr which was called: # once (5µs+0s) by Template::Stash::XS::BEGIN@17 at line 30
sub Template::Stash::CORE:qr; # opcode
Report produced by the NYTProf 6.02 Perl profiler, developed by Tim Bunce and Adam Kaplan.