File Coverage

blib/lib/Class/Declare/Hash.pm
Criterion Covered Total %
statement 91 92 98.9
branch 25 32 78.1
condition 17 32 53.1
subroutine 7 7 100.0
pod 1 1 100.0
total 141 164 85.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -Tw
2              
3             # $Id: Hash.pm 1518 2010-08-22 23:56:21Z ian $
4             package Class::Declare::Hash;
5              
6 28     28   133 use strict;
  28         42  
  28         1191  
7              
8             =head1 NAME
9              
10             Class::Declare::Hash - generate a hash of accessible attributes
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   131 use base qw( Class::Declare );
  28         44  
  28         2568  
21 28     28   154 use vars qw( $REVISION $VERSION );
  28         45  
  28         32480  
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 retrieval of an attribute/value hash representing a given
31             L derived object. This method is only installed (and indeed,
32             this module only compiled) if B is called on a
33             L-derived object or package.
34              
35             =cut
36             { # closure for hash() related methods and variables
37              
38             #
39             # Closure variables
40             #
41            
42             # references to subroutines that permit access to some of the
43             # Class::Declare data structures use to marshal objects and classes
44             my $__GET_ATTRIBUTES__; undef $__GET_ATTRIBUTES__;
45             my $__GET_VALUES__; undef $__GET_VALUES__;
46             my $__GET_FRIENDS__; undef $__GET_FRIENDS__;
47              
48              
49             # __init__()
50             #
51             # __init__() is used to obtain references to anonymous subroutines that
52             # give access to the %__ATTR__, %__FRIEND__ and %__DEFN__ hashes of
53             # Class::Declare. See the comment in Class::Declare::hash() for an
54             # explanation.
55             sub __init__ : method
56             {
57 28     28   1190 my $class = __PACKAGE__->class( shift );
58             # what's our method name?
59 28         2224 my $sub = ( caller 1 )[ 3 ];
60              
61             # make the reference assignment (only if it hasn't been done
62             # before)
63 28 50       1626 $__GET_ATTRIBUTES__ = $_[ 0 ] unless ( defined $__GET_ATTRIBUTES__ );
64 28 50       2205 $__GET_VALUES__ = $_[ 1 ] unless ( defined $__GET_VALUES__ );
65 28 50       101 $__GET_FRIENDS__ = $_[ 2 ] unless ( defined $__GET_FRIENDS__ );
66              
67 28         14195 1; # that's all: hack complete :)
68             }
69              
70              
71             # %__REFERENCES__
72             #
73             # Store attribute references for showing equality in the hash.
74             my %__REFERENCES__; undef %__REFERENCES__;
75              
76             # %__CALLER__
77             #
78             # Store the caller information for the original call to hash()
79             my %__CALLER__; undef %__CALLER__;
80              
81              
82             #
83             # Closure methods
84             #
85              
86             # $__permission__()
87             #
88             # For a given caller stack (as stored by $__save__() below) and target
89             # object (passed in as the first argument), determine if we have a given
90             # permission (e.g. public, private, protected, etc). Return true if we
91             # do, false otherwise.
92             #
93             # NB: these routines have been lifted directly from Class::Declare.
94             my $__permission__ = sub { # =>
95             my $type = shift; # the access control type
96             my $target = shift; # the object of interest
97             my $class = shift; # the target class
98            
99             # NB: the target class is not necessarily the same class as the
100             # target since methods/attributes may be inherited, in which
101             # case they belong to a different class
102              
103             # we need to know the calling context for this permission test -
104             # this will either be passed in as the third argument, or we can
105             # take it from the original calling context
106              
107             # first, we must be certain that the target is derived from
108             # Class::Declare
109             return undef unless ( UNIVERSAL::isa( $target ,
110             'Class::Declare' ) );
111              
112             # if we're testing class or abstract attributes, then that's all we need
113             return 1 if ( $type eq 'class' );
114             return 1 if ( $type eq 'abstract' );
115              
116             # if we're testing public attributes, then return true if this
117             # is a reference to an object
118             return ref( $target ) if ( $type eq 'public' );
119              
120             # OK, from here we're dealing with either restricted, protected,
121             # static or private attributes
122              
123             # get the friends of the target class
124             my $friend = $__GET_FRIENDS__->( $class ) || {};
125              
126             # if the caller is not in the same or a derived package, or is
127             # not a friend, then we can't proceed
128             my $caller = $__CALLER__{ package };
129             my $sub = $__CALLER__{ subroutine };
130             return undef unless ( UNIVERSAL::isa( $caller , $class )
131             || UNIVERSAL::isa( $class , $caller )
132             || $caller && exists $friend->{ $caller }
133             || $sub && exists $friend->{ $sub }
134             );
135              
136             # OK, if we're looking for restricted attributes we're done
137             return 1 if ( $type eq 'restricted' );
138              
139             # if we're looking for protected attributes, then we need a
140             # reference to return true
141             return ref( $target ) if ( $type eq 'protected' );
142              
143             # if the class is the same as the defining class then we can
144             # access static/private attributes, otherwise fail
145             return undef unless ( $class eq $caller
146             || $class->isa( $caller )
147             || exists $friend->{ $caller }
148             || exists $friend->{ $sub } );
149              
150             # that's all we need to check for static attributes
151             return 1 if ( $type eq 'static' );
152              
153             # otherwise, we need to make sure we have a reference for
154             # private attributes
155             return ref( $target ) if ( $type eq 'private' );
156              
157             return undef; # permission denied
158             }; # $__permission__()
159              
160              
161             # # $__save__()
162             #
163             # Save original calling state.
164             my $__save__ = sub { #
165             # need to store the original caller stack so that hash()
166             # can determined public(), private(), etc rights for the
167             # calling routine/context
168             $__CALLER__{ package } = ( caller 1 )[ 0 ];
169             $__CALLER__{ subroutine } = ( caller 2 )[ 3 ];
170              
171             # reset the references store
172             undef %__REFERENCES__;
173             }; # $__save__()
174              
175              
176             # $__clear__()
177             #
178             # Clear original calling state.
179             my $__clear__ = sub {
180             # clear the caller stack
181             %__CALLER__ = ();
182              
183             # reset the references store
184             undef %__REFERENCES__;
185             }; # $__clear__()
186              
187              
188             # $__hash__()
189             #
190             # Perform a recursive hash() expansion for a given value
191             my $__hash__;
192             $__hash__ = sub { # , ,
193             my $r = shift;
194             my $depth = shift;
195              
196             # if depth is zero, then return the value we have
197             return $r unless ( ! defined $depth || $depth > 0 );
198              
199             # if the value is undefined, then return undefined
200             return undef unless ( defined $r );
201              
202             # if we don't have a reference, then return the supplied value
203             return $r unless ( ref $r );
204              
205             # reduce the depth (if defined)
206             $depth-- if ( defined $depth );
207              
208             # we have a reference value
209             # - if it's an object derived from Class::Declare, then we should
210             # call its hash() method and perform a recursive expansion
211             # - if it's an ARRAY or HASH, we should iterate through its values
212             # and attempt to expand them (if possible)
213             foreach ( ref $r ) {
214             # array
215             /^ARRAY$/o && do {
216             my $ref = [];
217             push @{ $ref } , scalar $__hash__->( $_ , $depth , @_ )
218             foreach ( @{ $r } );
219              
220             # return the generated array
221             return $ref;
222             };
223              
224             # hash
225             /^HASH$/o && do {
226             my $ref = {};
227             while ( my ( $k , $v ) = each %{ $r } ) {
228             $ref->{ $k } = $__hash__->( $v , $depth , @_ )
229             }
230              
231             # return the generated hash
232             return $ref;
233             };
234              
235             # are we dealing with a Class::Declare object that supports the hash()
236             # method?
237             # - if so, recurse through that
238             UNIVERSAL::isa( $r , 'Class::Declare' )
239             and UNIVERSAL::can( $r , 'hash' )
240             and return scalar $r->hash( @_ , depth => $depth );
241             }
242              
243             # if we've made it this far, then simply return the value passed in
244             return $r;
245             }; # $__hash__()
246              
247              
248             # jump into the Class::Declare namespace to create the dump() routine
249             package Class::Declare;
250              
251              
252             # hash()
253             #
254             # Generate a textual representation of the object/class
255             sub hash : method
256             {
257 22     22 1 1902 my $self = Class::Declare->class( shift );
258 22   66     63 my $class = ref( $self ) || $self;
259              
260             # OK, parse the arguments
261 22         160 my $_args = $self->arguments( \@_ => { public => undef ,
262             private => undef ,
263             protected => undef ,
264             class => undef ,
265             static => undef ,
266             restricted => undef ,
267             abstract => undef ,
268             depth => undef ,
269             backtrace => 1 ,
270             all => 1 } );
271              
272             # have we been called from outside this file
273             # i.e. is this a non-recursive call (first call)
274 22         76 my $outside = ( caller )[ 1 ] ne __FILE__;
275              
276             # if we're called from outside this file (i.e. it's not an
277             # internal recursive call to hash()) then make
278             # note of the arguments and the context
279 22 100       401 $__save__->( $self , $_args ) if ( $outside );
280              
281             # store the current depth limit
282 22         30 my $depth = delete $_args->{ depth };
283              
284             # unset 'all' if any of the other arguments have been set
285             ( $_args->{ $_ } )
286             and delete $_args->{ all }
287             and last
288 22   66     176 foreach ( qw( public private protected abstract
      50        
289             class static restricted ) );
290              
291             # if we have asked for nothing, then return undef
292 176         192 return undef unless ( grep { defined }
293 22 50       29 map { $_args->{ $_ } }
  176         173  
294             qw( public private protected abstract
295             class static restricted all ) );
296              
297             # next, we need to check to ensure the user has permission to access the
298             # specified attribute types for the given object
299             # - this test should only be done at the top level
300 22 100       36 if ( $outside ) {
301             # make sure we have permission to access the specified attribute types
302             # or raise a fatal error (in keeping with the behaviour of
303             # Class::Declare
304             ( $__permission__->( $_ => $self => ref( $self ) || $self )
305             # also, if we don't have a reference, then we should raise an error
306             # if instance attributes have been requested
307             && ( ref( $self ) || !/^public$/o
308             && !/^private$/o
309             && !/^protected$/o ) )
310             or do {
311             # find out where the call to dump() was made
312 2         5 my ( undef , $file , $line , $sub ) = caller 0;
313              
314             # die with an informative error message
315 2         65 die "access to $_ attributes denied in call to "
316             . "$sub() at $file line $line\n";
317 16   66     17 } foreach ( grep { $_args->{ $_ } }
  112   0     108  
      33        
      33        
318 142   100     419 grep { !/all/o
319             && !/backtrace/o
320 16         30 } keys %{ $_args } );
321             }
322              
323             # determine the attribute types that may be returned/have been requested
324             # NB: if required, as this is first calculated during the
325             # top-level call to hash()
326 20         45 my @types = qw( abstract class static restricted
327             public private protected );
328 20 50       35 @types = grep { $_args->{ $_ } } @types unless ( $_args->{ all } );
  0         0  
329              
330             # generate the combined @ISA array for this class
331 20         50 my @isa = ( $class );
332 20         17 my $i = 0;
333 20         34 while ( $i <= $#isa ) {
334 28     28   190 no strict 'refs';
  28         63  
  28         17185  
335              
336 89 50       143 my $pkg = $isa[ $i++ ] or next;
337 89         70 push @isa , @{ $pkg . '::ISA' };
  89         252  
338             }
339             # remove the duplicates and reverse
340 20   33     54 @isa = local %_ || grep { ! $_{ $_ }++ } reverse @isa;
341              
342             # construct the list of public, private, class, etc attributes
343             # for this class (taking into account inheritance)
344 20         22 my %map; undef %map;
  20         25  
345 20         29 ISA: foreach my $isa ( @isa ) {
346 89 100       143 my $ref = $__GET_ATTRIBUTES__->( $isa ) or next ISA;
347              
348 22         20 while ( my ( $k , $v ) = each %{ $ref } ) {
  176         334  
349 154         111 $map{ $_ } = { type => $k , class => $isa } for ( @{ $v } );
  154         356  
350             }
351             }
352             # now build a reverse map of type to attribute
353 20         18 my %rmap; undef %rmap;
  20         20  
354 20         42 foreach my $attr ( keys %map ) {
355 134         122 my $type = $map{ $attr }->{ type };
356              
357 134         87 push @{ $rmap{ $type } } , $attr;
  134         185  
358             }
359              
360             # define a map for determining if a given attribute may be accessed
361             # through the given object/class
362             # NB: this takes into account the class defining the attribute, not
363             # just the class/object trying to access it
364             my $perm = sub {
365 134     134   115 my $object = shift;
366 134         95 my $attr = shift;
367              
368             # extract the attribute type and the class defining the
369             # attribute
370 134         105 my ( $type , $class ) = map { $map{ $attr }->{ $_ } }
  268         333  
371             qw( type class );
372              
373 134         174 return $__permission__->( $type => $object => $class );
374 20         72 }; # $perm()
375              
376             # get the object/class hash for this target
377             # - if we have an object, simply pass the object
378             # - otherwise, if we have a class, loop through all classes in its
379             # @ISA array
380             my $hash = ( ref $self ) ? $__GET_VALUES__->( $self )
381 12         9 : { map { %{ $_ } }
  12         47  
382 44         48 grep { defined }
383 20 100       55 map { $__GET_VALUES__->( $_ ) }
  44         68  
384             @isa
385             };
386              
387             # generate the return hash
388 20         23 my %rtn; undef %rtn;
  20         21  
389              
390 20         38 HASH: foreach my $type ( grep { exists $rmap{ $_ } } @types ) {
  140         160  
391             # print the attribute values we have access to
392 126         138 ATTR: foreach my $attr ( sort grep { $perm->( $self => $_ ) }
  134         166  
393 126         93 map { @{ $_ } }
  126         165  
394 126         188 grep { defined }
395             $rmap{ $type } ) {
396              
397             # what value do we have?
398 86         87 my $v = $hash->{ $attr };
399              
400             # if this is a reference
401 86 100       125 if ( ref $v ) {
402             # if we have backtrace turned on, then check to see if we have
403             # seen this reference before
404 46         59 my $r = $__REFERENCES__{ $v };
405              
406             # if we've not seen this reference before, then we should attempt
407             # to expand it
408 46 100       74 unless ( defined $r ) {
409             # if we have not reached our depth limit, then recurse if we need to
410             # - if the depth has not been given, then we descend as far
411             # as we can
412             # - NOTE: this is a change in default behaviour since v0.08
413 31 100 66     63 if ( ! defined $depth || $depth > 0 ) {
414             # generate the expansion of this value
415             # - decrement the depth count
416             #$depth-- if ( defined $depth );
417 29         23 $r = $__hash__->( $v , $depth , %{ $_args } );
  29         81  
418             }
419              
420             # if we don't have a reference, then use the original value
421 31   66     64 $r ||= $v;
422              
423             # the value we have now is all we are going to get for this
424             # attribute, so make sure it's stored (if we have backtracing turned
425             # on)
426 31 100       75 $__REFERENCES__{ $v } = $r if ( $_args->{ backtrace } );
427             }
428              
429             # use whatever expansion we have obtained
430 46         40 $v = $r;
431             }
432              
433             # record the expansion for this attribute
434 86         138 $rtn{ $attr } = $v;
435             }
436             }
437              
438             # if this is the final exit of hash() (i.e. this execution frame
439             # corresponds to the original invocation of hash() and not an internal
440             # recursive call, then we should clear the saved state information
441 20 100       43 $__clear__->() if ( $outside );
442              
443             # do we want a hash, or a has reference?
444 20 50       243 return ( wantarray ) ? %rtn : \%rtn;
445             } # hash()
446              
447             } # end hash() closure
448              
449              
450             =head1 SEE ALSO
451              
452             L
453              
454             =head1 AUTHOR
455              
456             Ian Brayshaw, Eibb@cpan.orgE
457              
458             =head1 COPYRIGHT AND LICENSE
459              
460             Copyright 2003-2016 by Ian Brayshaw. All rights reserved.
461              
462             This library is free software; you can redistribute it and/or modify
463             it under the same terms as Perl itself.
464              
465             =cut
466              
467             ############################################################################
468             1; # end of module
469             __END__