File Coverage

blib/lib/Template/Stash/Context.pm
Criterion Covered Total %
statement 102 174 58.6
branch 57 140 40.7
condition 36 90 40.0
subroutine 12 16 75.0
pod 7 7 100.0
total 214 427 50.1


line stmt bran cond sub pod time code
1             #============================================================= -*-Perl-*-
2             #
3             # Template::Stash::Context
4             #
5             # DESCRIPTION
6             # This is an alternate stash object which includes a patch from
7             # Craig Barratt to implement various new virtual methods to allow
8             # dotted template variable to denote if object methods and subroutines
9             # should be called in scalar or list context. It adds a little overhead
10             # to each stash call and I'm a little wary of doing that. So for now,
11             # it's implemented as a separate stash module which will allow us to
12             # test it out, benchmark it and switch it in or out as we require.
13             #
14             # This is what Craig has to say about it:
15             #
16             # Here's a better set of features for the core. Attached is a new version
17             # of Stash.pm (based on TT2.02) that:
18             #
19             # - supports the special op "scalar" that forces scalar context on
20             # function calls, eg:
21             #
22             # cgi.param("foo").scalar
23             #
24             # calls cgi.param("foo") in scalar context (unlike my wimpy
25             # scalar op from last night). Array context is the default.
26             #
27             # With non-function operands, scalar behaves like the perl
28             # version (eg: no-op for scalar, size for arrays, etc).
29             #
30             # - supports the special op "ref" that behaves like the perl ref.
31             # If applied to a function the function is not called. Eg:
32             #
33             # cgi.param("foo").ref
34             #
35             # does *not* call cgi.param and evaluates to "CODE". Similarly,
36             # HASH.ref, ARRAY.ref return what you expect.
37             #
38             # - adds a new scalar and list op called "array" that is a no-op for
39             # arrays and promotes scalars to one-element arrays.
40             #
41             # - allows scalar ops to be applied to arrays and hashes in place,
42             # eg: ARRAY.repeat(3) repeats each element in place.
43             #
44             # - allows list ops to be applied to scalars by promoting the scalars
45             # to one-element arrays (like an implicit "array"). So you can
46             # do things like SCALAR.size, SCALAR.join and get a useful result.
47             #
48             # This also means you can now use x.0 to safely get the first element
49             # whether x is an array or scalar.
50             #
51             # The new Stash.pm passes the TT2.02 test suite. But I haven't tested the
52             # new features very much. One nagging implementation problem is that the
53             # "scalar" and "ref" ops have higher precedence than user variable names.
54             #
55             # AUTHORS
56             # Andy Wardley
57             # Craig Barratt
58             #
59             # COPYRIGHT
60             # Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved.
61             # Copyright (C) 1998-2001 Canon Research Centre Europe Ltd.
62             #
63             # This module is free software; you can redistribute it and/or
64             # modify it under the same terms as Perl itself.
65             #
66             #============================================================================
67              
68             package Template::Stash::Context;
69              
70 1     1   1047 use strict;
  1         2  
  1         31  
71 1     1   5 use warnings;
  1         2  
  1         26  
72 1     1   4 use base 'Template::Stash';
  1         1  
  1         798  
73              
74             our $VERSION = 1.63;
75             our $DEBUG = 0 unless defined $DEBUG;
76              
77              
78             #========================================================================
79             # -- PACKAGE VARIABLES AND SUBS --
80             #========================================================================
81              
82             #------------------------------------------------------------------------
83             # copy virtual methods from those in the regular Template::Stash
84             #------------------------------------------------------------------------
85              
86             our $ROOT_OPS = {
87             %$Template::Stash::ROOT_OPS,
88             defined $ROOT_OPS ? %$ROOT_OPS : (),
89             };
90              
91             our $SCALAR_OPS = {
92             %$Template::Stash::SCALAR_OPS,
93             'array' => sub { return [$_[0]] },
94             defined $SCALAR_OPS ? %$SCALAR_OPS : (),
95             };
96              
97             our $LIST_OPS = {
98             %$Template::Stash::LIST_OPS,
99             'array' => sub { return $_[0] },
100             defined $LIST_OPS ? %$LIST_OPS : (),
101             };
102            
103             our $HASH_OPS = {
104             %$Template::Stash::HASH_OPS,
105             defined $HASH_OPS ? %$HASH_OPS : (),
106             };
107            
108              
109              
110             #========================================================================
111             # ----- CLASS METHODS -----
112             #========================================================================
113              
114             #------------------------------------------------------------------------
115             # new(\%params)
116             #
117             # Constructor method which creates a new Template::Stash object.
118             # An optional hash reference may be passed containing variable
119             # definitions that will be used to initialise the stash.
120             #
121             # Returns a reference to a newly created Template::Stash.
122             #------------------------------------------------------------------------
123              
124             sub new {
125 1     1 1 39 my $class = shift;
126 1 50       6 my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };
127              
128 1         11 my $self = {
129             global => { },
130             %$params,
131             %$ROOT_OPS,
132             '_PARENT' => undef,
133             '_CLASS' => $class,
134             };
135              
136 1         5 bless $self, $class;
137             }
138              
139              
140             #========================================================================
141             # ----- PUBLIC OBJECT METHODS -----
142             #========================================================================
143              
144             #------------------------------------------------------------------------
145             # clone(\%params)
146             #
147             # Creates a copy of the current stash object to effect localisation
148             # of variables. The new stash is blessed into the same class as the
149             # parent (which may be a derived class) and has a '_PARENT' member added
150             # which contains a reference to the parent stash that created it
151             # ($self). This member is used in a successive declone() method call to
152             # return the reference to the parent.
153             #
154             # A parameter may be provided which should reference a hash of
155             # variable/values which should be defined in the new stash. The
156             # update() method is called to define these new variables in the cloned
157             # stash.
158             #
159             # Returns a reference to a cloned Template::Stash.
160             #------------------------------------------------------------------------
161              
162             sub clone {
163 3     3 1 6 my ($self, $params) = @_;
164 3   50     8 $params ||= { };
165              
166             # look out for magical 'import' argument which imports another hash
167 3         7 my $import = $params->{ import };
168 3 50 33     10 if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
169 0         0 delete $params->{ import };
170             }
171             else {
172 3         5 undef $import;
173             }
174              
175 3         41 my $clone = bless {
176             %$self, # copy all parent members
177             %$params, # copy all new data
178             '_PARENT' => $self, # link to parent
179             }, ref $self;
180            
181             # perform hash import if defined
182 3 50       11 &{ $HASH_OPS->{ import }}($clone, $import)
  0         0  
183             if defined $import;
184              
185 3         11 return $clone;
186             }
187              
188            
189             #------------------------------------------------------------------------
190             # declone($export)
191             #
192             # Returns a reference to the PARENT stash. When called in the following
193             # manner:
194             # $stash = $stash->declone();
195             # the reference count on the current stash will drop to 0 and be "freed"
196             # and the caller will be left with a reference to the parent. This
197             # contains the state of the stash before it was cloned.
198             #------------------------------------------------------------------------
199              
200             sub declone {
201 3     3 1 4 my $self = shift;
202 3 50       14 $self->{ _PARENT } || $self;
203             }
204              
205              
206             #------------------------------------------------------------------------
207             # get($ident)
208             #
209             # Returns the value for an variable stored in the stash. The variable
210             # may be specified as a simple string, e.g. 'foo', or as an array
211             # reference representing compound variables. In the latter case, each
212             # pair of successive elements in the list represent a node in the
213             # compound variable. The first is the variable name, the second a
214             # list reference of arguments or 0 if undefined. So, the compound
215             # variable [% foo.bar('foo').baz %] would be represented as the list
216             # [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the
217             # identifier or an empty string if undefined. Errors are thrown via
218             # die().
219             #------------------------------------------------------------------------
220              
221             sub get {
222 15     15 1 41 my ($self, $ident, $args) = @_;
223 15         17 my ($root, $result);
224 15         18 $root = $self;
225              
226 15 100 100     82 if (ref $ident eq 'ARRAY'
  14   66     23  
227             || ($ident =~ /\./)
228 14         43 && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) {
229 11         22 my $size = $#$ident;
230              
231             # if $ident is a list reference, then we evaluate each item in the
232             # identifier against the previous result, using the root stash
233             # ($self) as the first implicit 'result'...
234              
235 11         26 foreach (my $i = 0; $i <= $size; $i += 2) {
236 20 100 100     83 if ( $i + 2 <= $size && ($ident->[$i+2] eq "scalar"
      66        
237             || $ident->[$i+2] eq "ref") ) {
238 2         10 $result = $self->_dotop($root, @$ident[$i, $i+1], 0,
239             $ident->[$i+2]);
240 2         4 $i += 2;
241             } else {
242 18         38 $result = $self->_dotop($root, @$ident[$i, $i+1]);
243             }
244 20 50       41 last unless defined $result;
245 20         55 $root = $result;
246             }
247             }
248             else {
249 4         14 $result = $self->_dotop($root, $ident, $args);
250             }
251              
252 15 100       81 return defined $result
253             ? $result
254             : $self->undefined($ident, $args);
255             }
256              
257              
258             #------------------------------------------------------------------------
259             # set($ident, $value, $default)
260             #
261             # Updates the value for a variable in the stash. The first parameter
262             # should be the variable name or array, as per get(). The second
263             # parameter should be the intended value for the variable. The third,
264             # optional parameter is a flag which may be set to indicate 'default'
265             # mode. When set true, the variable will only be updated if it is
266             # currently undefined or has a false value. The magical 'IMPORT'
267             # variable identifier may be used to indicate that $value is a hash
268             # reference whose values should be imported. Returns the value set,
269             # or an empty string if not set (e.g. default mode). In the case of
270             # IMPORT, returns the number of items imported from the hash.
271             #------------------------------------------------------------------------
272              
273             sub set {
274 7     7 1 16 my ($self, $ident, $value, $default) = @_;
275 7         9 my ($root, $result, $error);
276              
277 7         11 $root = $self;
278              
279 2         4 ELEMENT: {
280 7 100 100     8 if (ref $ident eq 'ARRAY'
  7   33     40  
281             || ($ident =~ /\./)
282 2         7 && ($ident = [ map { s/\(.*$//; ($_, 0) }
283             split(/\./, $ident) ])) {
284              
285             # a compound identifier may contain multiple elements (e.g.
286             # foo.bar.baz) and we must first resolve all but the last,
287             # using _dotop() with the $lvalue flag set which will create
288             # intermediate hashes if necessary...
289 1         2 my $size = $#$ident;
290 1         4 foreach (my $i = 0; $i < $size - 2; $i += 2) {
291 1         4 $result = $self->_dotop($root, @$ident[$i, $i+1], 1);
292 1 50       4 last ELEMENT unless defined $result;
293 1         3 $root = $result;
294             }
295              
296             # then we call _assign() to assign the value to the last element
297 1         4 $result = $self->_assign($root, @$ident[$size-1, $size],
298             $value, $default);
299             }
300             else {
301 6         18 $result = $self->_assign($root, $ident, 0, $value, $default);
302             }
303             }
304              
305 7 50       25 return defined $result ? $result : '';
306             }
307              
308              
309             #------------------------------------------------------------------------
310             # getref($ident)
311             #
312             # Returns a "reference" to a particular item. This is represented as a
313             # closure which will return the actual stash item when called.
314             # WARNING: still experimental!
315             #------------------------------------------------------------------------
316              
317             sub getref {
318 0     0 1 0 my ($self, $ident, $args) = @_;
319 0         0 my ($root, $item, $result);
320 0         0 $root = $self;
321              
322 0 0       0 if (ref $ident eq 'ARRAY') {
323 0         0 my $size = $#$ident;
324              
325 0         0 foreach (my $i = 0; $i <= $size; $i += 2) {
326 0         0 ($item, $args) = @$ident[$i, $i + 1];
327 0 0       0 last if $i >= $size - 2; # don't evaluate last node
328             last unless defined
329 0 0       0 ($root = $self->_dotop($root, $item, $args));
330             }
331             }
332             else {
333 0         0 $item = $ident;
334             }
335              
336 0 0       0 if (defined $root) {
337 0 0   0   0 return sub { my @args = (@{$args||[]}, @_);
  0         0  
338 0         0 $self->_dotop($root, $item, \@args);
339             }
340 0         0 }
341             else {
342 0     0   0 return sub { '' };
  0         0  
343             }
344             }
345              
346              
347              
348              
349             #------------------------------------------------------------------------
350             # update(\%params)
351             #
352             # Update multiple variables en masse. No magic is performed. Simple
353             # variable names only.
354             #------------------------------------------------------------------------
355              
356             sub update {
357 3     3 1 5 my ($self, $params) = @_;
358              
359             # look out for magical 'import' argument to import another hash
360 3         5 my $import = $params->{ import };
361 3 50 33     11 if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
362 0         0 @$self{ keys %$import } = values %$import;
363 0         0 delete $params->{ import };
364             }
365              
366 3         12 @$self{ keys %$params } = values %$params;
367             }
368              
369              
370             #========================================================================
371             # ----- PRIVATE OBJECT METHODS -----
372             #========================================================================
373              
374             #------------------------------------------------------------------------
375             # _dotop($root, $item, \@args, $lvalue, $nextItem)
376             #
377             # This is the core 'dot' operation method which evaluates elements of
378             # variables against their root. All variables have an implicit root
379             # which is the stash object itself (a hash). Thus, a non-compound
380             # variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is
381             # '(stash.)foo.bar'. The first parameter is a reference to the current
382             # root, initially the stash itself. The second parameter contains the
383             # name of the variable element, e.g. 'foo'. The third optional
384             # parameter is a reference to a list of any parenthesised arguments
385             # specified for the variable, which are passed to sub-routines, object
386             # methods, etc. The final parameter is an optional flag to indicate
387             # if this variable is being evaluated on the left side of an assignment
388             # (e.g. foo.bar.baz = 10). When set true, intermediated hashes will
389             # be created (e.g. bar) if necessary.
390             #
391             # Returns the result of evaluating the item against the root, having
392             # performed any variable "magic". The value returned can then be used
393             # as the root of the next _dotop() in a compound sequence. Returns
394             # undef if the variable is undefined.
395             #------------------------------------------------------------------------
396              
397             sub _dotop {
398 25     25   42 my ($self, $root, $item, $args, $lvalue, $nextItem) = @_;
399 25         34 my $rootref = ref $root;
400 25         25 my ($value, @result, $ret, $retVal);
401 25   100     74 $nextItem ||= "";
402 25 100       50 my $scalarContext = 1 if ( $nextItem eq "scalar" );
403 25 100       46 my $returnRef = 1 if ( $nextItem eq "ref" );
404              
405 25   100     76 $args ||= [ ];
406 25   100     75 $lvalue ||= 0;
407              
408             # print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n"
409             # if $DEBUG;
410              
411             # return undef without an error if either side of the dot is unviable
412             # or if an attempt is made to access a private member, starting _ or .
413             return undef
414 25 50 33     160 unless defined($root) and defined($item) and $item !~ /^[\._]/;
      33        
415              
416 25 0 33     73 if (ref(\$root) eq "SCALAR" && !$lvalue &&
      0        
      33        
417             (($value = $LIST_OPS->{ $item }) || $item =~ /^-?\d+$/) ) {
418             #
419             # Promote scalar to one element list, to be processed below.
420             #
421 0         0 $rootref = 'ARRAY';
422 0         0 $root = [$root];
423             }
424 25 100 100     92 if ($rootref eq $self->{_CLASS} || $rootref eq 'HASH') {
    50 0        
    0 0        
    0          
    0          
425              
426             # if $root is a regular HASH or a Template::Stash kinda HASH (the
427             # *real* root of everything). We first lookup the named key
428             # in the hash, or create an empty hash in its place if undefined
429             # and the $lvalue flag is set. Otherwise, we check the HASH_OPS
430             # pseudo-methods table, calling the code if found, or return undef.
431              
432 24 100       88 if (defined($value = $root->{ $item })) {
    50          
    50          
    50          
    50          
433 21         41 ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
434             $scalarContext);
435 21 100       95 return $retVal if ( $ret ); ## RETURN
436             }
437             elsif ($lvalue) {
438             # we create an intermediate hash if this is an lvalue
439 0         0 return $root->{ $item } = { }; ## RETURN
440             }
441             elsif ($value = $HASH_OPS->{ $item }) {
442 0         0 @result = &$value($root, @$args); ## @result
443             }
444             elsif (ref $item eq 'ARRAY') {
445             # hash slice
446 0         0 return [@$root{@$item}]; ## RETURN
447             }
448             elsif ($value = $SCALAR_OPS->{ $item }) {
449             #
450             # Apply scalar ops to every hash element, in place.
451             #
452 0         0 foreach my $key ( keys %$root ) {
453 0         0 $root->{$key} = &$value($root->{$key}, @$args);
454             }
455             }
456             }
457             elsif ($rootref eq 'ARRAY') {
458              
459             # if root is an ARRAY then we check for a LIST_OPS pseudo-method
460             # (except for l-values for which it doesn't make any sense)
461             # or return the numerical index into the array, or undef
462              
463 1 50 33     10 if (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
    0 0        
    0          
    0          
464 1         7 @result = &$value($root, @$args); ## @result
465             }
466             elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
467             #
468             # Apply scalar ops to every array element, in place.
469             #
470 0         0 for ( my $i = 0 ; $i < @$root ; $i++ ) {
471 0         0 $root->[$i] = &$value($root->[$i], @$args); ## @result
472             }
473             }
474             elsif ($item =~ /^-?\d+$/) {
475 0         0 $value = $root->[$item];
476 0         0 ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
477             $scalarContext);
478 0 0       0 return $retVal if ( $ret ); ## RETURN
479             }
480             elsif (ref $item eq 'ARRAY' ) {
481             # array slice
482 0         0 return [@$root[@$item]]; ## RETURN
483             }
484             }
485              
486             # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
487             # doesn't appear to work with CGI, returning true for the first call
488             # and false for all subsequent calls.
489              
490             elsif (ref($root) && UNIVERSAL::can($root, 'can')) {
491              
492             # if $root is a blessed reference (i.e. inherits from the
493             # UNIVERSAL object base class) then we call the item as a method.
494             # If that fails then we try to fallback on HASH behaviour if
495             # possible.
496 0 0       0 return ref $root->can($item) if ( $returnRef ); ## RETURN
497 0         0 eval {
498 0 0       0 @result = $scalarContext ? scalar $root->$item(@$args)
499             : $root->$item(@$args); ## @result
500             };
501              
502 0 0       0 if ($@) {
503             # failed to call object method, so try some fallbacks
504 0 0 0     0 if (UNIVERSAL::isa($root, 'HASH')
    0 0        
505             && defined($value = $root->{ $item })) {
506 0         0 ($ret, $retVal, @result) = _dotop_return($value, $args,
507             $returnRef, $scalarContext);
508 0 0       0 return $retVal if ( $ret ); ## RETURN
509             }
510             elsif (UNIVERSAL::isa($root, 'ARRAY')
511             && ($value = $LIST_OPS->{ $item })) {
512 0         0 @result = &$value($root, @$args);
513             }
514             else {
515 0         0 @result = (undef, $@);
516             }
517             }
518             }
519             elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
520              
521             # at this point, it doesn't look like we've got a reference to
522             # anything we know about, so we try the SCALAR_OPS pseudo-methods
523             # table (but not for l-values)
524              
525 0         0 @result = &$value($root, @$args); ## @result
526             }
527             elsif ($self->{ _DEBUG }) {
528 0         0 die "don't know how to access [ $root ].$item\n"; ## DIE
529             }
530             else {
531 0         0 @result = ();
532             }
533              
534             # fold multiple return items into a list unless first item is undef
535 10 100       31 if (defined $result[0]) {
    50          
    50          
536 7 0       13 return ref(@result > 1 ? [ @result ] : $result[0])
    50          
537             if ( $returnRef ); ## RETURN
538 7 100       12 if ( $scalarContext ) {
539 1 50       4 return scalar @result if ( @result > 1 ); ## RETURN
540 1 50       6 return scalar(@{$result[0]}) if ( ref $result[0] eq "ARRAY" );
  0         0  
541 1 50       4 return scalar(%{$result[0]}) if ( ref $result[0] eq "HASH" );
  0         0  
542 1         5 return $result[0]; ## RETURN
543             } else {
544 6 100       26 return @result > 1 ? [ @result ] : $result[0]; ## RETURN
545             }
546             }
547             elsif (defined $result[1]) {
548 0         0 die $result[1]; ## DIE
549             }
550             elsif ($self->{ _DEBUG }) {
551 0         0 die "$item is undefined\n"; ## DIE
552             }
553              
554 3         10 return undef;
555             }
556              
557             #------------------------------------------------------------------------
558             # ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
559             # $scalarContext);
560             #
561             # Handle the various return processing for _dotop
562             #------------------------------------------------------------------------
563              
564             sub _dotop_return
565             {
566 21     21   26 my($value, $args, $returnRef, $scalarContext) = @_;
567 21         19 my(@result);
568              
569 21 100       36 return (1, ref $value) if ( $returnRef ); ## RETURN
570 20 100       28 if ( $scalarContext ) {
571 1 50       5 return (1, scalar(@$value)) if ref $value eq 'ARRAY'; ## RETURN
572 1 50       7 return (1, scalar(%$value)) if ref $value eq 'HASH'; ## RETURN
573 1 50       4 return (1, scalar($value)) unless ref $value eq 'CODE'; ## RETURN;
574 1         6 @result = scalar &$value(@$args) ## @result;
575             } else {
576 19 100       59 return (1, $value) unless ref $value eq 'CODE'; ## RETURN
577 5         11 @result = &$value(@$args); ## @result
578             }
579 6         45 return (0, undef, @result);
580             }
581              
582              
583             #------------------------------------------------------------------------
584             # _assign($root, $item, \@args, $value, $default)
585             #
586             # Similar to _dotop() above, but assigns a value to the given variable
587             # instead of simply returning it. The first three parameters are the
588             # root item, the item and arguments, as per _dotop(), followed by the
589             # value to which the variable should be set and an optional $default
590             # flag. If set true, the variable will only be set if currently false
591             # (undefined/zero)
592             #------------------------------------------------------------------------
593              
594             sub _assign {
595 7     7   13 my ($self, $root, $item, $args, $value, $default) = @_;
596 7         20 my $rootref = ref $root;
597 7         8 my $result;
598 7   50     35 $args ||= [ ];
599 7   50     28 $default ||= 0;
600              
601             # print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n",
602             # "value=$value, default=$default)\n")
603             # if $DEBUG;
604              
605             # return undef without an error if either side of the dot is unviable
606             # or if an attempt is made to update a private member, starting _ or .
607             return undef ## RETURN
608 7 50 33     58 unless $root and defined $item and $item !~ /^[\._]/;
      33        
609            
610 7 50 66     32 if ($rootref eq 'HASH' || $rootref eq $self->{_CLASS}) {
    0 0        
    0          
611             # if the root is a hash we set the named key
612 7 50 33     37 return ($root->{ $item } = $value) ## RETURN
613             unless $default && $root->{ $item };
614             }
615             elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) {
616             # or set a list item by index number
617 0 0 0       return ($root->[$item] = $value) ## RETURN
618             unless $default && $root->{ $item };
619             }
620             elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) {
621             # try to call the item as a method of an object
622 0           return $root->$item(@$args, $value); ## RETURN
623             }
624             else {
625 0           die "don't know how to assign to [$root].[$item]\n"; ## DIE
626             }
627              
628 0           return undef;
629             }
630              
631              
632             #------------------------------------------------------------------------
633             # _dump()
634             #
635             # Debug method which returns a string representing the internal state
636             # of the object. The method calls itself recursively to dump sub-hashes.
637             #------------------------------------------------------------------------
638              
639             sub _dump {
640 0     0     my $self = shift;
641 0   0       my $indent = shift || 1;
642 0           my $buffer = ' ';
643 0           my $pad = $buffer x $indent;
644 0           my $text = '';
645 0           local $" = ', ';
646              
647 0           my ($key, $value);
648              
649              
650 0 0         return $text . "...excessive recursion, terminating\n"
651             if $indent > 32;
652              
653 0           foreach $key (keys %$self) {
654              
655 0           $value = $self->{ $key };
656 0 0         $value = '' unless defined $value;
657              
658 0 0         if (ref($value) eq 'ARRAY') {
659 0           $value = "$value [@$value]";
660             }
661 0           $text .= sprintf("$pad%-8s => $value\n", $key);
662 0 0         next if $key =~ /^\./;
663 0 0         if (UNIVERSAL::isa($value, 'HASH')) {
664 0           $text .= _dump($value, $indent + 1);
665             }
666             }
667 0           $text;
668             }
669              
670              
671             1;
672              
673             __END__