File Coverage

blib/lib/Class/Declare/Dump.pm
Criterion Covered Total %
statement 132 134 98.5
branch 34 42 80.9
condition 26 43 60.4
subroutine 7 7 100.0
pod 1 1 100.0
total 200 227 88.1


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -Tw
2              
3             # $Id: Dump.pm 1518 2010-08-22 23:56:21Z ian $
4             package Class::Declare::Dump;
5              
6 28     28   141 use strict;
  28         46  
  28         1121  
7              
8             =head1 NAME
9              
10             Class::Declare::Dump - provide object dump routine for Class::Declare
11              
12             =head1 SYNOPSIS
13              
14             This module should not be used directly; it is a helper module for
15             L, providing the B routine.
16              
17             =cut
18              
19              
20 28     28   140 use base qw( Class::Declare );
  28         43  
  28         2547  
21 28     28   152 use vars qw( $REVISION $VERSION );
  28         50  
  28         47396  
22              
23             $REVISION = '$Revision: 1518 $';
24             $VERSION = '0.20'; # Class::Declare->VERSION;
25              
26              
27             =head1 DESCRIPTION
28              
29             B adds a detailed B method to L,
30             allowing inspection of L derived objects. This method is only
31             installed (and indeed, this module only compiled) if B is called on
32             a L-derived object or package.
33              
34             =cut
35             { # closure for dump() related methods and variables
36              
37             #
38             # Closure variables
39             #
40            
41             # references to subroutines that permit access to some of the
42             # Class::Declare data structures use to marshal objects and classes
43             my $__GET_ATTRIBUTES__; undef $__GET_ATTRIBUTES__;
44             my $__GET_VALUES__; undef $__GET_VALUES__;
45             my $__GET_FRIENDS__; undef $__GET_FRIENDS__;
46              
47              
48             # __init__()
49             #
50             # __init__() is used to obtain references to anonymous subroutines that
51             # give access to the %__ATTR__, %__FRIEND__ and %__DEFN__ hashes of
52             # Class::Declare. See the comment in Class::Declare::dump() for an
53             # explanation.
54             sub __init__ : method
55             {
56 28     28   247 my $class = __PACKAGE__->class( shift );
57             # what's our method name?
58 28         1047 my $sub = ( caller 1 )[ 3 ];
59              
60             # make the reference assignment (only if it hasn't been done
61             # before)
62 28 50       2938 $__GET_ATTRIBUTES__ = $_[ 0 ] unless ( defined $__GET_ATTRIBUTES__ );
63 28 50       1728 $__GET_VALUES__ = $_[ 1 ] unless ( defined $__GET_VALUES__ );
64 28 50       872 $__GET_FRIENDS__ = $_[ 2 ] unless ( defined $__GET_FRIENDS__ );
65              
66 28         110 1; # that's all: hack complete :)
67             }
68              
69              
70             # %__REFERENCES__
71             #
72             # Store attribute references for showing equality in the dump.
73             my %__REFERENCES__; undef %__REFERENCES__;
74              
75             # $__INDENT__
76             #
77             # Current indentation level for this invocation
78             my $__INDENT__; undef $__INDENT__;
79              
80             # $__ARGS__
81             #
82             # Original calling arguments for dump(), minus the
83             # object/instance/class
84             my $__ARGS__; undef $__ARGS__;
85              
86             # %__CALLER__
87             #
88             # Store the caller information for the original call to dump()
89             my %__CALLER__; undef %__CALLER__;
90              
91              
92             #
93             # Closure methods
94             #
95              
96             # $__permission__()
97             #
98             # For a given caller stack (as stored by $__save__() below) and target
99             # object (passed in as the first argument), determine if we have a given
100             # permission (e.g. public, private, protected, etc). Return true if we
101             # do, false otherwise.
102             #
103             # NB: these routines have been lifted directly from Class::Declare.
104             my $__permission__ = sub { # =>
105             my $type = shift; # the access control type
106             my $target = shift; # the object of interest
107             my $class = shift; # the target class
108            
109             # NB: the target class is not necessarily the same class as the
110             # target since methods/attributes may be inherited, in which
111             # case they belong to a different class
112              
113             # we need to know the calling context for this permission test -
114             # this will either be passed in as the third argument, or we can
115             # take it from the original calling context
116              
117             # first, we must be certain that the target is derived from
118             # Class::Declare
119             return undef unless ( $target->isa( 'Class::Declare' ) );
120              
121             # if we're testing class or abstract attributes, then that's all we need
122             return 1 if ( $type eq 'class' );
123             return 1 if ( $type eq 'abstract' );
124              
125             # if we're testing public attributes, then return true if this
126             # is a reference to an object
127             return ref( $target ) if ( $type eq 'public' );
128              
129             # OK, from here we're dealing with either restricted, protected,
130             # static or private attributes
131              
132             # get the friends of the target class
133             my $friend = $__GET_FRIENDS__->( $class ) || {};
134              
135             # if the caller is not in the same or a derived package, or is
136             # not a friend, then we can't proceed
137             my $caller = $__CALLER__{ package };
138             my $sub = $__CALLER__{ subroutine };
139             return undef unless ( $caller->isa( $class )
140             || $class->isa( $caller )
141             || $caller && exists $friend->{ $caller }
142             || $sub && exists $friend->{ $sub }
143             );
144              
145             # OK, if we're looking for restricted attributes we're done
146             return 1 if ( $type eq 'restricted' );
147              
148             # if we're looking for protected attributes, then we need a
149             # reference to return true
150             return ref( $target ) if ( $type eq 'protected' );
151              
152             # if the class is the same as the defining class then we can
153             # access static/private attributes, otherwise fail
154             return undef unless ( $class eq $caller
155             || $class->isa( $caller )
156             || exists $friend->{ $caller }
157             || exists $friend->{ $sub } );
158              
159             # that's all we need to check for static attributes
160             return 1 if ( $type eq 'static' );
161              
162             # otherwise, we need to make sure we have a reference for
163             # private attributes
164             return ref( $target ) if ( $type eq 'private' );
165              
166             return undef; # permission denied
167             }; # $__permission__()
168              
169              
170             # $__isnum__()
171             #
172             # Return true if the first argument is a number.
173             # - should probably use Scalar::Util, but for now we'll stick with this
174             my $__isnum__ = sub {
175             # certain strings can cause the lines after this one to throw a
176             # warning, so let's try to catch it out
177             return 0 if ( $_[ 0 ] =~ /\W/o );
178              
179             # suppress all warnings from the eval() call
180             local $SIG{ __WARN__ } = sub {};
181              
182             my $value = ( eval $_[ 0 ] ) || $_[ 0 ];
183             return ( ( $value & ~$value ) eq '0' );
184             }; # $__isnum__()
185              
186             # $__quote__()
187             #
188             # Return the quoted representation of a scalar value
189             # i.e. strings are singly quoted, with appropriate escaping,
190             # and numbers are left as is
191             # NB: if we're given a reference, then that reference is simply
192             # stringified
193             my $__quote__ = sub {
194             # if we have an undefined value return the string
195             # 'undef'
196             return 'undef' unless ( defined $_[ 0 ] );
197              
198             # if this is just a number, then don't quote it
199             return $_[ 0 ] if ( $__isnum__->( $_[ 0 ] ) );
200              
201             # if we've got a reference, then just stringify it
202             return "$_[ 0 ]" if ( ref $_[ 0 ] );
203              
204             # otherwise, should quote
205             return "'$_[ 0 ]'";
206             }; # $__quote__()
207              
208              
209             # $__dump__()
210             #
211             # Return a string representation for a given value.
212             my $__dump__;
213             $__dump__ = sub { # []
214             # if we're at the bottom of our recursion, then
215             # simply return the value given
216             return $__quote__->( $_[ 0 ] )
217             unless ( ! defined $_[ 1 ] || $_[ 1 ] > 0 );
218              
219             # set the depth for (possibly) limiting recursion
220             # - if the depth is defined, then decrement it
221             my $depth = $_[ 1 ];
222             $depth-- if ( defined $depth );
223              
224             # otherwise, we should examine this value and recurse
225             # accordingly
226              
227             # if we don't have a reference, then just return the
228             # correctly quoted value
229             return $__quote__->( $_[ 0 ] ) unless ( ref $_[ 0 ] );
230              
231             # what sort of reference do we have?
232             REF: foreach ( ref $_[ 0 ] ) {
233             # scalar
234             /^SCALAR$/o && do {
235             # return the scalar prefixed with a \
236             return '\\' . $__quote__->( ${ $_[ 0 ] } );
237             };
238              
239             # array
240             /^ARRAY$/o && do {
241             # return the list of elements in []s
242             return '[ ' . join( ', ' ,
243             map { $__dump__->( $_ , $depth ) }
244             @{ $_[ 0 ] }
245             )
246             . ' ]';
247             };
248              
249             # hash
250             /^HASH$/o && do {
251             # return a list of key => value pairs in {}s
252             return '{ ' . join( ', ' ,
253             map { join ' => ' ,
254             $__quote__->( $_ ) ,
255             $__dump__->( $_[ 0 ]->{ $_ } ,
256             $depth
257             )
258             } sort keys %{ $_[ 0 ] } )
259             . ' }';
260             };
261              
262             # code
263             /^CODE$/o && last REF;
264              
265             # object that has a dump() method, and is derived from
266             # Class::Declare
267             UNIVERSAL::isa( $_[ 0 ] , 'Class::Declare' )
268             && UNIVERSAL::can( $_[ 0 ] , 'dump' )
269             && do {
270             # if we have the depth set then we need to pass it
271             # with the list of arguments
272             my @args = @{ $__ARGS__ };
273             push @args , ( depth => $depth )
274             if ( defined $depth );
275              
276             # call dump() and recurse
277             return $_[ 0 ]->dump( @args );
278             };
279             }
280              
281             # otherwise, just return the quoted value
282             return $__quote__->( $_[ 0 ] );
283             }; # $__dump__();
284              
285              
286             # # $__save__()
287             #
288             # Save original calling state.
289             my $__save__ = sub { #
290             # reset the indentation counter
291             undef $__INDENT__;
292              
293             # undefine the reference tracking hash
294             undef %__REFERENCES__;
295              
296             # need to store the original caller stack so that dump()
297             # can determined public(), private(), etc rights for the
298             # calling routine/context
299             $__CALLER__{ package } = ( caller 1 )[ 0 ];
300             $__CALLER__{ subroutine } = ( caller 2 )[ 3 ];
301              
302             # store the display indentation so that recursive calls to
303             # dump() are consistent with the first call
304             # - we don't need to pass any other arguments to recursive
305             # calls because, in short, it doesn't make sense
306             # e.g. if dump() is called to display an object's private
307             # attributes, and one of the attribute values is
308             # another Class::Declare-derived object, then we
309             # should show all attributes (honouring permissions)
310             # of that object, not just the private attributes
311             # (which we may or may not have permission to show)
312             my $indent = $_[ 1 ]->{ indent };
313             my $backtrace = $_[ 1 ]->{ backtrace };
314             $__ARGS__ = [ backtrace => $_[ 1 ]->{ backtrace } ];
315             ( defined $indent )
316             and push @{ $__ARGS__ } , indent => $indent;
317             }; # $__save__()
318              
319              
320             # $__clear__()
321             #
322             # Clear original calling state.
323             my $__clear__ = sub {
324             # reset the indentation counter
325             undef $__INDENT__;
326              
327             # undefine the reference tracking hash
328             undef %__REFERENCES__;
329              
330             # clear the caller stack
331             %__CALLER__ = ();
332              
333             # clear the list of command-line arguments
334             undef $__ARGS__;
335             }; # $__clear__()
336              
337              
338             # jump into the Class::Declare namespace to create the dump() routine
339             package Class::Declare;
340              
341              
342             # dump()
343             #
344             # Generate a textual representation of the object/class
345             sub dump : method
346             {
347 96     96 1 7563 my $self = Class::Declare->class( shift );
348 96   66     254 my $class = ref( $self ) || $self;
349              
350             # OK, parse the arguments
351 96         711 my $_args = $self->arguments( \@_ => { public => undef ,
352             private => undef ,
353             protected => undef ,
354             class => undef ,
355             static => undef ,
356             restricted => undef ,
357             friends => undef ,
358             abstract => undef ,
359             depth => undef ,
360             backtrace => 1 ,
361             indent => 4 ,
362             all => 1 } );
363              
364             # have we been called from outside this file
365             # i.e. is this a non-recursive call (first call)
366 94         351 my $outside = ( caller )[ 1 ] ne __FILE__;
367              
368             # if we're called from outside this file (i.e. it's not an
369             # internal recursive call to dump() from $__dump__()) then make
370             # note of the arguments and the context
371 94 100       1567 $__save__->( $self , $_args ) if ( $outside );
372              
373             # store the current depth limit
374 94         141 my $depth = delete $_args->{ depth };
375              
376             # make sure the indentation is sensible
377 94   50     220 $_args->{ indent } ||= 0;
378             ( $_args->{ indent } >= 0 )
379 94 50       161 or do {
380 0         0 my ( undef , $file , $line , $sub ) = caller 0;
381              
382 0         0 die "indentation must be greater than or equal to zero "
383             . " in call to $sub() at $file line $line\n";
384             };
385              
386             # unset 'all' if any of the other arguments have been set
387             ( $_args->{ $_ } )
388             and delete $_args->{ all }
389             and last
390 94   66     838 foreach ( qw( public private protected abstract
      50        
391             class static restricted friends ) );
392              
393             # if we have asked for nothing, then return undef
394 846         989 return undef unless ( grep { defined }
395 94 100       109 map { $_args->{ $_ } }
  846         848  
396             qw( public private protected abstract
397             class static restricted friends
398             all ) );
399              
400             # next, we need to check to ensure the user has permission to access the
401             # specified attribute types for the given object
402             # - this test should only be done at the top level
403 92 100       172 if ( $outside ) {
404             # ignoring friends, indentation and the all argument, make sure we
405             # have permission to access the specified attribute types
406             # or raise a fatal error (in keeping with the behaviour of
407             # Class::Declare
408             ( $__permission__->( $_ => $self => ref( $self ) || $self )
409             # also, if we don't have a reference, then we should raise an error
410             # if instance attributes have been requested
411             && ( ref( $self ) || !/^public$/o
412             && !/^private$/o
413             && !/^protected$/o ) )
414             or do {
415             # find out where the call to dump() was made
416 4         10 my ( undef , $file , $line , $sub ) = caller 0;
417              
418             # die with an informative error message
419 4         125 die "access to $_ attributes denied in call to "
420             . "$sub() at $file line $line\n";
421 61   66     59 } foreach ( grep { $_args->{ $_ } }
  427   33     469  
      66        
      66        
422 657   100     2850 grep { !/all/o
423             && !/friends/o
424             && !/indent/o
425             && !/backtrace/o
426 61         141 } keys %{ $_args } );
427             }
428              
429             # create a list of dump lines
430 88         113 my @dump; undef @dump;
  88         100  
431             # increase the indentation
432 88         102 $__INDENT__ += $_args->{ indent };
433              
434             # display order: class, static, restricted, public, private, protected
435             # and friends
436             #
437             # determine the attribute types that may be displayed/have been requested
438             # NB: if required, as this is first calculated during the
439             # top-level call to dump()
440 88         189 my @types = qw( abstract class static restricted
441             public private protected );
442 88 100       159 @types = grep { $_args->{ $_ } } @types unless ( $_args->{ all } );
  70         75  
443             # if we've been asked to list friends, then add this separately
444 88 100       144 push @types , 'friends' if ( $_args->{ friends } );
445              
446             # generate the combined @ISA array for this class
447 88         98 my @isa = ( $class );
448 88         78 my $i = 0;
449 88         152 while ( $i <= $#isa ) {
450 28     28   189 no strict 'refs';
  28         53  
  28         30170  
451              
452 330 50       523 my $pkg = $isa[ $i++ ] or next;
453 330         323 push @isa , @{ $pkg . '::ISA' };
  330         1091  
454             }
455             # remove the duplicates and reverse
456 88   33     276 @isa = local %_ || grep { ! $_{ $_ }++ } reverse @isa;
457              
458             # construct the list of public, private, class, etc attributes
459             # for this class (taking into account inheritance)
460 88         104 my %map; undef %map;
  88         119  
461 88         131 ISA: foreach my $isa ( @isa ) {
462 330 100       580 my $ref = $__GET_ATTRIBUTES__->( $isa ) or next ISA;
463              
464 86         85 while ( my ( $k , $v ) = each %{ $ref } ) {
  688         1397  
465 602         418 $map{ $_ } = { type => $k , class => $isa } for ( @{ $v } );
  602         1502  
466             }
467             }
468             # now build a reverse map of type to attribute
469 88         82 my %rmap; undef %rmap;
  88         100  
470 88         194 foreach my $attr ( keys %map ) {
471 462         426 my $type = $map{ $attr }->{ type };
472              
473 462         324 push @{ $rmap{ $type } } , $attr;
  462         774  
474             }
475              
476             # if we've been asked to list friends, then we need to add this to the
477             # reverse map
478 88         129 $rmap{ $_ } = undef foreach ( grep { $_ eq 'friends' } @types );
  560         644  
479              
480             # define a map for determining if a given attribute may be accessed
481             # through the given object/class
482             # NB: this takes into account the class defining the attribute, not
483             # just the class/object trying to access it
484             my $perm = sub {
485 822     822   752 my $object = shift;
486 822         650 my $attr = shift;
487              
488             # extract the attribute type and the class defining the
489             # attribute
490 822         714 my ( $type , $class ) = map { $map{ $attr }->{ $_ } }
  1644         2225  
491             qw( type class );
492              
493 822         1084 return $__permission__->( $type => $object => $class );
494 88         315 }; # $perm()
495              
496             # remember which references we've seen
497 88         92 my %refs; undef %refs;
  88         85  
498              
499             # determine the maximum length of attribute names for this map
500             # - make sure we only take into account the attributes we can actually
501             # see
502 88         83 my $length = 0;
503             ( $length < length )
504             and $length = length
505 88   66     142 foreach ( grep { $perm->( $self => $_ ) } keys %map );
  462         572  
506              
507             # get the object/class hash for this target
508             # - if we have an object, simply pass the object
509             # - otherwise, if we have a class, loop through all classes in its
510             # @ISA array
511             my $hash = ( ref $self ) ? $__GET_VALUES__->( $self )
512 21         14 : { map { %{ $_ } }
  21         111  
513 86         109 grep { defined }
514 88 100       242 map { $__GET_VALUES__->( $_ ) }
  86         159  
515             @isa
516             };
517              
518             # OK, generate the dump
519 88         122 DUMP: foreach my $type ( grep { exists $rmap{ $_ } } @types ) {
  560         706  
520             # set the type heading
521 415         703 my $heading = ' ' x $__INDENT__ . $type . ':';
522              
523             # increase the indentation
524 415         473 $__INDENT__ += $_args->{ indent };
525              
526             # if we're displaying abstract class/attributes, then just list
527             # the methods and attributes as listed (no values)
528             ( $type eq 'abstract' )
529 415 100       688 and do {
530             # do we need to add the type heading?
531 51 50 50     156 push @dump , $heading
532             and undef $heading if ( defined $heading );
533              
534             # add the list of abstract attributes and methods
535 51         108 push @dump , map { ( ' ' x $__INDENT__ ) . $_ }
536 51         31 sort map { @{ $_ } }
  51         111  
537 51         80 grep { defined }
538 51         68 $rmap{ $type };
539              
540             # reduce the indent and loop again
541 51         62 $__INDENT__ -= $_args->{ indent };
542 51         111 next DUMP;
543             };
544              
545             # if we're displaying class friend information, then just
546             # list the methods and classes as listed
547             ( $type eq 'friends' )
548 364 100       524 and do {
549             # do we need to add the type heading?
550 4 50 50     18 push @dump , $heading
551             and undef $heading if ( defined $heading );
552              
553             # add the list of friends
554 4         10 push @dump , map { ( ' ' x $__INDENT__ ) . $_ }
555 2         2 map { sort keys %{ $_ } }
  2         11  
556 4         11 grep { defined }
  4         7  
557             $__GET_FRIENDS__->( $class );
558              
559             # reduce the indent and loop again
560 4         7 $__INDENT__ -= $_args->{ indent };
561 4         7 next DUMP;
562             };
563              
564             # OK, we have class, public, private and protected attributes
565             # to display
566              
567             # for each attribute, extract the value and add it to the
568             # dump string
569 360         288 my $string; undef $string;
  360         308  
570              
571             # print the attribute values we have access to
572 360         505 ATTR: foreach my $attr ( sort grep { $perm->( $self => $_ ) }
  360         499  
573 360         323 map { @{ $_ } }
  360         656  
574 360         671 grep { defined }
575             $rmap{ $type } ) {
576              
577             # extract the attribute value from the lookup table
578 200         222 my $value = $hash->{ $attr };
579              
580             # add the attribute name to the string
581 200         672 $string = sprintf( '%-*s = ' , $length , $attr );
582              
583 200         179 my $str = undef;
584             # if this is a reference, then we should look at a cache
585             # of previously encountered references and see if we can
586             # match the reference with another attribute
587             # NB: this prevents infinite recursion through circular
588             # references
589 200 100 66     554 if ( ref $value && $_args->{ backtrace } ) {
590 126         178 $str = $__REFERENCES__{ $value };
591 126 100       250 unless ( $str ) {
592             # OK, if we've seen this object before (i.e. $self),
593             # then we should show where it came from
594 111   66     313 my $origin = $__REFERENCES__{ $self } || $self;
595              
596 111         328 $__REFERENCES__{ $value } = join '->' , $origin , $attr;
597 111         194 $str = $__dump__->($value , $depth);
598             }
599              
600             # otherwise, just dump the value
601             } else {
602 74         124 $str .= $__dump__->( $value , $depth );
603             }
604              
605             # OK, need to perform indenting for $str to make sure it
606             # lines up with the rest of the output
607 200         377 $str =~ s#\n#"\n" . ( ' ' x length( $string ) )#egm;
  278         483  
608              
609             # add this to the string
610 200         255 $string .= $str;
611              
612             # do we need to add the type heading?
613 200 50 50     709 push @dump , $heading
614             and undef $heading if ( defined $heading );
615              
616             # add this string to the output
617 200         541 push @dump , ( ' ' x $__INDENT__ ) . $string;
618             }
619              
620             # reduce the indentation
621 360         570 $__INDENT__ -= $_args->{ indent };
622             }
623              
624             # drop a level in the indentation
625 88         113 $__INDENT__ -= $_args->{ indent };
626              
627             # if this is the top level call to dump() (i.e. no recursion)
628             # then add a newline to the end of the dump string
629 88 100       162 push @dump , '' if ( $outside );
630              
631             # if this is the final exit of dump() (i.e. this execution frame
632             # corresponds to the original invocation of dump() and not an internal
633             # recursive call, then we should clear the saved state information
634 88 100       165 $__clear__->() if ( $outside );
635              
636             # return the dump() string
637 88         1306 return join "\n" , $self , @dump;
638             } # dump()
639              
640             } # end dump() closure
641              
642              
643             =head1 SEE ALSO
644              
645             L
646              
647             =head1 AUTHOR
648              
649             Ian Brayshaw, Eibb@cpan.orgE
650              
651             =head1 COPYRIGHT AND LICENSE
652              
653             Copyright 2003-2016 by Ian Brayshaw. All rights reserved.
654              
655             This library is free software; you can redistribute it and/or modify
656             it under the same terms as Perl itself.
657              
658             =cut
659              
660             ############################################################################
661             1; # end of module
662             __END__