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   129 use strict;
  28         50  
  28         838  
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   127 use base qw( Class::Declare );
  28         50  
  28         2068  
21 28     28   126 use vars qw( $REVISION $VERSION );
  28         48  
  28         33411  
22              
23             $REVISION = '$Revision: 1518 $';
24             $VERSION = '0.17'; # 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   1337 my $class = __PACKAGE__->class( shift );
58             # what's our method name?
59 28         3565 my $sub = ( caller 1 )[ 3 ];
60              
61             # make the reference assignment (only if it hasn't been done
62             # before)
63 28 50       361 $__GET_ATTRIBUTES__ = $_[ 0 ] unless ( defined $__GET_ATTRIBUTES__ );
64 28 50       3632 $__GET_VALUES__ = $_[ 1 ] unless ( defined $__GET_VALUES__ );
65 28 50       109 $__GET_FRIENDS__ = $_[ 2 ] unless ( defined $__GET_FRIENDS__ );
66              
67 28         14940 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 3132 my $self = Class::Declare->class( shift );
258 22   66     72 my $class = ref( $self ) || $self;
259              
260             # OK, parse the arguments
261 22         184 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         90 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       523 $__save__->( $self , $_args ) if ( $outside );
280              
281             # store the current depth limit
282 22         40 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     226 foreach ( qw( public private protected abstract
      50        
289             class static restricted ) );
290              
291             # if we have asked for nothing, then return undef
292 176         292 return undef unless ( grep { defined }
293 22 50       39 map { $_args->{ $_ } }
  176         276  
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       52 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         91 die "access to $_ attributes denied in call to "
316             . "$sub() at $file line $line\n";
317 16   66     20 } foreach ( grep { $_args->{ $_ } }
  112   0     187  
      33        
      33        
318 142   100     695 grep { !/all/o
319             && !/backtrace/o
320 16         44 } 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         56 my @types = qw( abstract class static restricted
327             public private protected );
328 20 50       43 @types = grep { $_args->{ $_ } } @types unless ( $_args->{ all } );
  0         0  
329              
330             # generate the combined @ISA array for this class
331 20         31 my @isa = ( $class );
332 20         25 my $i = 0;
333 20         46 while ( $i <= $#isa ) {
334 28     28   173 no strict 'refs';
  28         59  
  28         18006  
335              
336 89 50       184 my $pkg = $isa[ $i++ ] or next;
337 89         95 push @isa , @{ $pkg . '::ISA' };
  89         330  
338             }
339             # remove the duplicates and reverse
340 20   33     60 @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         27 my %map; undef %map;
  20         34  
345 20         35 ISA: foreach my $isa ( @isa ) {
346 89 100       205 my $ref = $__GET_ATTRIBUTES__->( $isa ) or next ISA;
347              
348 22         28 while ( my ( $k , $v ) = each %{ $ref } ) {
  176         467  
349 154         174 $map{ $_ } = { type => $k , class => $isa } for ( @{ $v } );
  154         554  
350             }
351             }
352             # now build a reverse map of type to attribute
353 20         28 my %rmap; undef %rmap;
  20         25  
354 20         56 foreach my $attr ( keys %map ) {
355 134         182 my $type = $map{ $attr }->{ type };
356              
357 134         150 push @{ $rmap{ $type } } , $attr;
  134         294  
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   176 my $object = shift;
366 134         193 my $attr = shift;
367              
368             # extract the attribute type and the class defining the
369             # attribute
370 134         183 my ( $type , $class ) = map { $map{ $attr }->{ $_ } }
  268         526  
371             qw( type class );
372              
373 134         297 return $__permission__->( $type => $object => $class );
374 20         84 }; # $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         12 : { map { %{ $_ } }
  12         65  
382 44         81 grep { defined }
383 20 100       64 map { $__GET_VALUES__->( $_ ) }
  44         101  
384             @isa
385             };
386              
387             # generate the return hash
388 20         34 my %rtn; undef %rtn;
  20         34  
389              
390 20         30 HASH: foreach my $type ( grep { exists $rmap{ $_ } } @types ) {
  140         273  
391             # print the attribute values we have access to
392 126         218 ATTR: foreach my $attr ( sort grep { $perm->( $self => $_ ) }
  134         232  
393 126         136 map { @{ $_ } }
  126         265  
394 126         282 grep { defined }
395             $rmap{ $type } ) {
396              
397             # what value do we have?
398 86         121 my $v = $hash->{ $attr };
399              
400             # if this is a reference
401 86 100       189 if ( ref $v ) {
402             # if we have backtrace turned on, then check to see if we have
403             # seen this reference before
404 46         84 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       91 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     83 if ( ! defined $depth || $depth > 0 ) {
414             # generate the expansion of this value
415             # - decrement the depth count
416             #$depth-- if ( defined $depth );
417 29         33 $r = $__hash__->( $v , $depth , %{ $_args } );
  29         103  
418             }
419              
420             # if we don't have a reference, then use the original value
421 31   66     84 $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       123 $__REFERENCES__{ $v } = $r if ( $_args->{ backtrace } );
427             }
428              
429             # use whatever expansion we have obtained
430 46         72 $v = $r;
431             }
432              
433             # record the expansion for this attribute
434 86         222 $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       54 $__clear__->() if ( $outside );
442              
443             # do we want a hash, or a has reference?
444 20 50       300 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, Eian@onemore.orgE
457              
458             =head1 COPYRIGHT AND LICENSE
459              
460             Copyright 2003-2010 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__