← Index
NYTProf Performance Profile   « line view »
For rbm/rbm
  Run on Wed Feb 12 03:38:15 2020
Reported on Wed Feb 12 04:56:37 2020

Filename/usr/lib/x86_64-linux-gnu/perl5/5.28/Template/Stash.pm
StatementsExecuted 8132522 statements in 23.6s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
384174218.98s8.98sTemplate::Stash::::cloneTemplate::Stash::clone
383161114.33s4.33sTemplate::Stash::::newTemplate::Stash::new
383161112.60s2.60sTemplate::Stash::::updateTemplate::Stash::update
4084912741.56s1.56sTemplate::Stash::::undefinedTemplate::Stash::undefined
384174211.08s1.08sTemplate::Stash::::decloneTemplate::Stash::declone
1113.93ms4.17msTemplate::Stash::::BEGIN@24Template::Stash::BEGIN@24
11111µs13µsTemplate::Stash::::BEGIN@22Template::Stash::BEGIN@22
1118µs8µsTemplate::Stash::::BEGIN@25Template::Stash::BEGIN@25
1117µs41µsTemplate::Stash::::BEGIN@26Template::Stash::BEGIN@26
1115µs18µsTemplate::Stash::::BEGIN@23Template::Stash::BEGIN@23
1113µs3µsTemplate::Stash::::CORE:qrTemplate::Stash::CORE:qr (opcode)
2212µs2µsTemplate::Stash::::__ANON__Template::Stash::__ANON__ (xsub)
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
22219µs215µs
# spent 13µs (11+2) within Template::Stash::BEGIN@22 which was called: # once (11µs+2µs) by Template::Stash::XS::BEGIN@17 at line 22
use strict;
# spent 13µs making 1 call to Template::Stash::BEGIN@22 # spent 2µs making 1 call to strict::import
23217µs231µs
# spent 18µs (5+13) within Template::Stash::BEGIN@23 which was called: # once (5µs+13µs) by Template::Stash::XS::BEGIN@17 at line 23
use warnings;
# spent 18µs making 1 call to Template::Stash::BEGIN@23 # spent 13µs making 1 call to warnings::import
242738µs24.17ms
# spent 4.17ms (3.93+239µs) within Template::Stash::BEGIN@24 which was called: # once (3.93ms+239µs) by Template::Stash::XS::BEGIN@17 at line 24
use Template::VMethods;
# spent 4.17ms making 1 call to Template::Stash::BEGIN@24 # spent 1µs making 1 call to Template::Stash::__ANON__
25228µs29µs
# spent 8µs (8+400ns) within Template::Stash::BEGIN@25 which was called: # once (8µs+400ns) by Template::Stash::XS::BEGIN@17 at line 25
use Template::Exception;
# spent 8µs making 1 call to Template::Stash::BEGIN@25 # spent 400ns making 1 call to Template::Stash::__ANON__
2622.31ms274µs
# spent 41µs (7+34) within Template::Stash::BEGIN@26 which was called: # once (7µs+34µs) by Template::Stash::XS::BEGIN@17 at line 26
use Scalar::Util qw( blessed reftype );
# spent 41µs making 1 call to Template::Stash::BEGIN@26 # spent 34µs making 1 call to Exporter::import
27
281400nsour $VERSION = 2.91;
291300nsour $DEBUG = 0 unless defined $DEBUG;
30111µs13µsour $PRIVATE = qr/^[_.]/;
# spent 3µs making 1 call to Template::Stash::CORE:qr
311400nsour $UNDEF_TYPE = 'var.undef';
321200nsour $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
3611µ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
491200ns ? { %{$Template::VMethods::ROOT_VMETHODS}, %$ROOT_OPS }
50 : $Template::VMethods::ROOT_VMETHODS;
51
52our $SCALAR_OPS = defined $SCALAR_OPS
531200ns ? { %{$Template::VMethods::TEXT_VMETHODS}, %$SCALAR_OPS }
54 : $Template::VMethods::TEXT_VMETHODS;
55
56our $HASH_OPS = defined $HASH_OPS
571100ns ? { %{$Template::VMethods::HASH_VMETHODS}, %$HASH_OPS }
58 : $Template::VMethods::HASH_VMETHODS;
59
60our $LIST_OPS = defined $LIST_OPS
611200ns ? { %{$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 4.33s within Template::Stash::new which was called 383161 times, avg 11µs/call: # 383161 times (4.33s+0s) by Template::Config::stash at line 195 of Template/Config.pm, avg 11µs/call
sub new {
112383161167ms my $class = shift;
113383161462ms my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
114
1153831612.61s my $self = {
116 global => { },
117 %$params,
118 %$ROOT_OPS,
119 '_PARENT' => undef,
120 };
121
1223831612.02s 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 8.98s within Template::Stash::clone which was called 384174 times, avg 23µs/call: # 383161 times (8.92s+0s) by Template::Context::localise at line 567 of Template/Context.pm, avg 23µs/call # 1013 times (53.3ms+0s) by Template::Context::process at line 312 of Template/Context.pm, avg 53µs/call
sub clone {
149384174249ms my ($self, $params) = @_;
150384174204ms $params ||= { };
151
152 # look out for magical 'import' argument which imports another hash
153384174362ms my $import = $params->{ import };
154384174419ms if (defined $import && ref $import eq 'HASH') {
155 delete $params->{ import };
156 }
157 else {
15838417493.4ms undef $import;
159 }
160
1613841746.49s 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
168384174223ms &{ $HASH_OPS->{ import } }($clone, $import)
169 if defined $import;
170
1713841741.86s 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 1.08s within Template::Stash::declone which was called 384174 times, avg 3µs/call: # 383161 times (1.08s+0s) by Template::Context::delocalise at line 572 of Template/Context.pm, avg 3µs/call # 1013 times (1.77ms+0s) by Template::Context::process at line 380 of Template/Context.pm, avg 2µs/call
sub declone {
187384174192ms my $self = shift;
1883841741.90s $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 2.60s within Template::Stash::update which was called 383161 times, avg 7µs/call: # 383161 times (2.60s+0s) by Template::Context::process at line 317 of Template/Context.pm, avg 7µs/call
sub update {
335383161270ms my ($self, $params) = @_;
336
337 # look out for magical 'import' argument to import another hash
338383161452ms my $import = $params->{ import };
339383161272ms if (defined $import && ref $import eq 'HASH') {
340 @$self{ keys %$import } = values %$import;
341 delete $params->{ import };
342 }
343
3443831612.60s @$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 1.56s within Template::Stash::undefined which was called 408491 times, avg 4µs/call: # 383161 times (1.48s+0s) by Template::Stash::XS::get at line 323 of Template/Context.pm, avg 4µs/call # 6063 times (16.4ms+0s) by Template::Stash::XS::get at line 1 of /root/tor-browser-build/input text, avg 3µs/call # 3982 times (11.8ms+0s) by Template::Stash::XS::get at line 11 of /root/tor-browser-build/input text, avg 3µs/call # 1992 times (4.89ms+0s) by Template::Stash::XS::get at line 2 of /root/tor-browser-build/input text, avg 2µs/call # 1991 times (6.42ms+0s) by Template::Stash::XS::get at line 33 of /root/tor-browser-build/input text, avg 3µs/call # 1991 times (5.51ms+0s) by Template::Stash::XS::get at line 16 of /root/tor-browser-build/input text, avg 3µs/call # 1991 times (3.75ms+0s) by Template::Stash::XS::get at line 23 of /root/tor-browser-build/input text, avg 2µs/call # 1990 times (6.63ms+0s) by Template::Stash::XS::get at line 6 of /root/tor-browser-build/input text, avg 3µs/call # 1007 times (4.46ms+0s) by Template::Stash::XS::get at line 21 of /root/tor-browser-build/input text, avg 4µs/call # 995 times (3.45ms+0s) by Template::Stash::XS::get at line 18 of /root/tor-browser-build/input text, avg 3µs/call # 995 times (3.25ms+0s) by Template::Stash::XS::get at line 9 of /root/tor-browser-build/input text, avg 3µs/call # 993 times (3.04ms+0s) by Template::Stash::XS::get at line 17 of /root/tor-browser-build/input text, avg 3µs/call # 720 times (1.87ms+0s) by Template::Stash::XS::get at line 24 of /root/tor-browser-build/input text, avg 3µs/call # 471 times (2.29ms+0s) by Template::Stash::XS::get at line 13 of /root/tor-browser-build/input text, avg 5µs/call # 15 times (50µs+0s) by Template::Stash::XS::get at line 5 of /root/tor-browser-build/input text, avg 3µs/call # 15 times (36µs+0s) by Template::Stash::XS::get at line 33 of /root/tor-browser-build/projects/common/runc-config.json, avg 2µs/call # 15 times (34µs+0s) by Template::Stash::XS::get at line 8 of /root/tor-browser-build/projects/common/runc-config.json, avg 2µs/call # 15 times (20µs+0s) by Template::Stash::XS::get at line 49 of /root/tor-browser-build/projects/common/runc-config.json, avg 1µs/call # 15 times (18µs+0s) by Template::Stash::XS::get at line 65 of /root/tor-browser-build/projects/common/runc-config.json, avg 1µs/call # 15 times (17µs+0s) by Template::Stash::XS::get at line 81 of /root/tor-browser-build/projects/common/runc-config.json, avg 1µs/call # 15 times (17µs+0s) by Template::Stash::XS::get at line 97 of /root/tor-browser-build/projects/common/runc-config.json, avg 1µs/call # 14 times (200µs+0s) by Template::Stash::XS::get at line 239 of /root/tor-browser-build/projects/common/runc-config.json, avg 14µs/call # 14 times (31µs+0s) by Template::Stash::XS::get at line 25 of /root/tor-browser-build/input text, avg 2µs/call # 7 times (32µs+0s) by Template::Stash::XS::get at line 22 of /root/tor-browser-build/input text, avg 5µs/call # 4 times (16µs+0s) by Template::Stash::XS::get at line 22 of /root/tor-browser-build/projects/snowflake/build, avg 4µs/call # 3 times (11µs+0s) by Template::Stash::XS::get at line 10 of /root/tor-browser-build/input text, avg 4µs/call # 2 times (4µs+0s) by Template::Stash::XS::get at line 8 of /root/tor-browser-build/input text, avg 2µs/call
sub undefined {
356408491371ms my ($self, $ident, $args) = @_;
357
358408491358ms if ($self->{ _STRICT }) {
359 # Sorry, but we can't provide a sensible source file and line without
360 # re-designing the whole architecture 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.
3714084912.03s 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 propagate 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 3µs within Template::Stash::CORE:qr which was called: # once (3µs+0s) by Template::Stash::XS::BEGIN@17 at line 30
sub Template::Stash::CORE:qr; # opcode
# spent 2µs within Template::Stash::__ANON__ which was called 2 times, avg 800ns/call: # once (1µs+0s) by Template::Stash::BEGIN@24 at line 24 # once (400ns+0s) by Template::Stash::BEGIN@25 at line 25
sub Template::Stash::__ANON__; # xsub
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.