File Coverage

blib/lib/Class/Ref.pm
Criterion Covered Total %
statement 127 127 100.0
branch 23 24 95.8
condition 11 12 91.6
subroutine 46 46 100.0
pod 1 1 100.0
total 208 210 99.0


line stmt bran cond sub pod time code
1             package Class::Ref;
2              
3             =head1 NAME
4              
5             Class::Ref - Automatic OO wrapping of container references
6              
7             =head1 SYNOPSIS
8              
9             $o = Class::Ref->new({ foo => { bar => 'Hello World!' } });
10             $o->foo->bar; # returns "Hello World!"
11             $o->baz({ blah => 123 });
12             $o->baz->blah; # returns 123
13              
14             $o = Class::Ref->new({ foo => [{ bar => 'Hello Again!' }] });
15             $o->foo->[0]->bar; # returns "Hello Again!"
16              
17             =head1 DESCRIPTION
18              
19             L provides an OO wrapping layer around Hash and Array references.
20             Part of the magic is that it does this deeply and across array/hash boundaries.
21              
22             =cut
23              
24 8     8   222121 use strict;
  8         22  
  8         282  
25 8     8   40 use warnings;
  8         13  
  8         240  
26              
27 8     8   40 use Scalar::Util ();
  8         15  
  8         174  
28 8     8   40 use Carp ();
  8         27  
  8         4475  
29              
30             our $VERSION = '0.05';
31              
32             =head1 OPTIONS
33              
34             Some of the behavior of the encapsulation can be modified by the following options:
35              
36             =over 4
37              
38             =item B<$raw_access> (Default: 0)
39              
40             $o = Class::Ref->new({ foo => { bar => 1 } });
41             {
42             $Class::Ref::raw_access = 1;
43             $o->foo; # returns { bar => 1 }
44             }
45              
46             Should you ever need to work with the raw contents of the data structure,
47             setting C<$raw_access> with cause every member retrieval to just the referenced
48             data rather than a wrapped form of it.
49              
50             The observant reader will note that this does not provide access to the base
51             data. In order to access that, you must dereference the object:
52              
53             $$o; # returns { foo => { bar => 1 } } unblessed
54              
55             See L for more information.
56              
57             =cut
58              
59             # bypass wrapping and access the raw data structure
60             our $raw_access = 0;
61              
62             =item B<$allow_undef> (Default: 0)
63              
64             $o = Class::Ref->new({ foo => { bar => 1 } });
65             {
66             $Class::Ref::allow_undef = 1;
67             $o->not_here; # returns undef
68             }
69             $o->not_here; # raises exception
70              
71             By default, an excpetion will be raised if you try read from a HASH key that is
72             non-existent.
73              
74             =back
75              
76             =cut
77              
78             # instead of raising an exception when accessing a non-existent value,
79             # return 'undef' instead
80             our $allow_undef = 0;
81              
82             # disable defaults at your peril
83             our %nowrap = map { ($_ => 1) } (
84             'Regexp', 'CODE', 'SCALAR', 'REF', 'LVALUE', 'VSTRING',
85             'GLOB', 'IO', 'FORMAT'
86             );
87              
88             my $bless = sub {
89             my ($class, $ref) = @_;
90             return $ref if $raw_access;
91             my $type = ref $ref;
92             return bless \$ref => "$class\::$type";
93             };
94              
95             my $test = sub {
96             return unless $_[0] and ref $_[0];
97             return if Scalar::Util::blessed $_[0];
98             return if $nowrap{ ref $_[0] };
99             1;
100             };
101              
102             my $assign = sub {
103             my $v = shift;
104             $$v = shift if @_;
105             return $test->($$v) ? \__PACKAGE__->$bless($$v) : $v;
106             };
107              
108             =head1 METHODS
109              
110             There is only the constructor.
111              
112             =over 4
113              
114             =item B
115              
116             $o = Class::Ref->new({...});
117             $o = Class::Ref->new([...]);
118              
119             Wrap the provided reference in OO getters and setters.
120              
121             =back
122              
123             =cut
124              
125             sub new {
126 15     15 1 9758 my ($class, $ref) = @_;
127 15 100       124 Carp::croak "not a valid reference for $class" unless $test->($ref);
128 7         33 return $class->$bless($ref);
129             }
130              
131             =head1 PHILOSOPHY
132              
133             A lot of effort has been made to ensure that the only code that changes your
134             wrapped data is your code. There is no blessing of any of the data wrapped
135             by L.
136              
137             With that being said, the goal has been to reduce the syntax need to access
138             values deep inside a HASH/ARRAY reference.
139              
140             =head1 HASH Refs
141              
142             Wrapping a HASH is a fairly straightforward process. All keys of the hash will
143             be made available as a method call.
144              
145             There is a bit more here however. If, for example, you accessed the actual hash,
146             L will still encapsulate the return value if that value is a HASH or
147             an ARRAY:
148              
149             $o = Class::Ref->new({ foo => { bar => 1 } });
150             $o->{foo}->bar; # works
151              
152             But all without modifying, blessing, or otherwise messing with the value. The
153             data referenced with C<$o> remains the same as when it originally wrapped.
154              
155             =cut
156              
157             package Class::Ref::HASH;
158              
159 8     8   54 use strict;
  8         14  
  8         271  
160 8     8   270 use warnings;
  8         21  
  8         920  
161              
162             use overload '%{}' => sub {
163 14 100   14   1450 return ${ $_[0] } if $raw_access;
  1         8  
164 13         22 tie my %h, __PACKAGE__ . '::Tie', ${ $_[0] };
  13         79  
165 13         79 \%h;
166             },
167 8     8   16303 fallback => 1;
  8         9475  
  8         71  
168              
169             our $AUTOLOAD;
170              
171             sub AUTOLOAD {
172             # enable access to $h->{AUTOLOAD}
173 36 100   36   11050 my $name
174             = defined $AUTOLOAD
175             ? substr($AUTOLOAD, 1 + rindex $AUTOLOAD, ':')
176             : 'AUTOLOAD';
177              
178             # undef so that we can detect if next call is for $h->{AUTOLOAD}
179             # - needed cause $AUTOLOAD stays set to previous value until next call
180 36         58 undef $AUTOLOAD;
181              
182             # NOTE must do this after AUTOLOAD check
183             # - weird things happen when a wrapped HASH is an element of a wrapped
184             # ARRAY. tie'd ARRAYs have some lvalue magic on their FETCHed values.
185             # As a result, this call to shift triggers the tie object call to FETCH
186             # to ensure the lvalue is still valid.
187 36         59 my $self = shift;
188              
189             # simulate a fetch for a non-existent key without autovivification
190 36 100 100     188 unless (exists $$self->{$name} or @_) {
191 2 100 66     14 return undef if $allow_undef or $name eq 'DESTROY';
192 1         175 Carp::croak sprintf 'Can\'t locate object method "%s" via package "%s"',
193             $name,
194             ref $self;
195             }
196              
197             # keep this broken up in case I decide to implement lvalues
198 34         159 my $o = $assign->(\$$self->{$name}, @_);
199 34         185 $$o;
200             }
201              
202             package Class::Ref::HASH::Tie;
203              
204 8     8   1711 use strict;
  8         29  
  8         233  
205 8     8   37 use warnings;
  8         16  
  8         2614  
206              
207             # borrowed from Tie::StdHash (in Tie::Hash)
208              
209             #<<< ready... steady... cross-eyed!!
210 13     13   54 sub TIEHASH { bless [$_[1]], $_[0] }
211 1     1   6 sub STORE { $_[0][0]->{ $_[1] } = $_[2] }
212 2     2   27 sub FETCH { ${ $assign->(\$_[0][0]->{ $_[1] }) } } # magic
  2         9  
213 2     2   3 sub FIRSTKEY { my $a = scalar keys %{ $_[0][0] }; each %{ $_[0][0] } }
  2         7  
  2         4  
  2         12  
214 2     2   3 sub NEXTKEY { each %{ $_[0][0] } }
  2         11  
215 2     2   14 sub EXISTS { exists $_[0][0]->{ $_[1] } }
216 1     1   7 sub DELETE { delete $_[0][0]->{ $_[1] } }
217 1     1   3 sub CLEAR { %{ $_[0][0] } = () }
  1         6  
218 1     1   2 sub SCALAR { scalar %{ $_[0][0] } }
  1         9  
219             #>>>
220              
221             =head1 ARRAY Refs
222              
223             Wrapping ARRAYs is much less straightforward. Using an C method
224             doesn't help because perl symbols cannot begin with a number. Makes it a
225             little difficult to do the following:
226              
227             $o->0; # compile error
228              
229             So for the purpose of this module, wrapped ARRAYs exactly like an ARRAY
230             reference:
231              
232             $o->[0]; # ahh, much better
233              
234             The tricky part comes in wanting to make sure that values returned from such a
235             call would still be wrapped:
236              
237             $o->[0]->foo; # $o = [{ foo => 'bar' }]
238              
239             See L for more discussion on how this is done.
240              
241             I am still debating if adding formal accessors moethods would be helpful in
242             this context.
243              
244             =cut
245              
246             package Class::Ref::ARRAY;
247              
248 8     8   105 use strict;
  8         18  
  8         292  
249 8     8   45 use warnings;
  8         21  
  8         707  
250              
251             # tie a proxy array around the real one
252             use overload '@{}' => sub {
253 33 100   33   7230 return ${ $_[0] } if $raw_access;
  2         11  
254 31         39 tie my @a, __PACKAGE__ . '::Tie', ${ $_[0] };
  31         180  
255 31         172 \@a;
256             },
257 8     8   34 fallback => 1;
  8         20  
  8         51  
258              
259             sub index {
260 2     2   3 my $self = shift;
261 2 100       113 defined(my $i = shift) or Carp::croak "No index given";
262 1         2 ${ $assign->(\$$self->[$i], @_) };
  1         9  
263             }
264              
265             sub iterator {
266 1     1   546 my $self = shift;
267 1         3 my $raw = $raw_access;
268 1         3 my $i = 0;
269             return sub {
270             # preserve access mode for the life of the iterator
271 1     1   4 local $raw_access = $raw;
272 1         3 ${ $assign->(\$$self->[$i++]) } ;
  1         5  
273 1         8 };
274             }
275              
276             our $AUTOLOAD;
277              
278             sub AUTOLOAD {
279             # enable access to $o->caller::AUTOLOAD
280 9 100   9   1239 my $name
281             = defined $AUTOLOAD
282             ? substr($AUTOLOAD, 1 + rindex $AUTOLOAD, ':')
283             : 'AUTOLOAD';
284              
285             # undef so that we can detect if next call is for $o->caller::AUTOLOAD
286             # - needed cause $AUTOLOAD stays set to previous value until next call
287 9         13 undef $AUTOLOAD;
288              
289 9 50       24 return if $name eq 'DESTROY';
290              
291             # NOTE must do this after AUTOLOAD check
292             # - weird things happen when a wrapped ARRAY is an element of a wrapped
293             # ARRAY. tie'd ARRAYs have some lvalue magic on their FETCHed values.
294             # As a result, this call to shift triggers the tie object call to FETCH
295             # to ensure the lvalue is still valid.
296 9         12 my $self = shift;
297              
298             # honor @ISA if the caller is using it
299 9         25 my $pkg = caller;
300 9 100       66 my $idx = $pkg->can($name) ? $pkg->$name : undef;
301              
302             {
303 8     8   2925 no warnings 'numeric';
  8         13  
  8         1202  
  9         12  
304 9 100 100     357 defined $idx and $idx eq int($idx)
305             or Carp::croak "'$name' is not a numeric constant in '$pkg'";
306             }
307              
308             # simulate a fetch for a non-existent index without autovivification
309 7 100 100     37 return undef unless exists $$self->[$idx] or @_;
310              
311             # keep this broken up in case I decide to implement lvalues
312 6         21 my $o = $assign->(\$$self->[$idx], @_);
313 6         29 $$o;
314             }
315              
316             package Class::Ref::ARRAY::Tie;
317              
318 8     8   61 use strict;
  8         26  
  8         243  
319 8     8   35 use warnings;
  8         18  
  8         3586  
320              
321             # borrowed from Tie::StdArray (in Tie::Array)
322              
323             #<<< ready... steady... cross-eyed!!
324 31     31   125 sub TIEARRAY { bless [$_[1]] => $_[0] }
325 3     3   6 sub FETCHSIZE { scalar @{ $_[0][0] } }
  3         18  
326 2     2   4 sub STORESIZE { $#{ $_[0][0] } = $_[1] - 1 }
  2         11  
327 1     1   6 sub STORE { $_[0][0]->[$_[1]] = $_[2] }
328 15     15   121 sub FETCH { ${ $assign->(\$_[0][0][$_[1]]) } } # magic
  15         64  
329 1     1   2 sub CLEAR { @{ $_[0][0] } = () }
  1         9  
330 1     1   2 sub POP { pop @{ $_[0][0] } }
  1         6  
331 2     2   5 sub PUSH { my $o = shift->[0]; push @$o, @_ }
  2         10  
332 1     1   2 sub SHIFT { shift @{ $_[0][0] } }
  1         7  
333 1     1   3 sub UNSHIFT { my $o = shift->[0]; unshift @$o, @_ }
  1         5  
334 1     1   7 sub EXISTS { exists $_[0][0]->[$_[1]] }
335 1     1   7 sub DELETE { delete $_[0][0]->[$_[1]] }
336 1     1   7 sub EXTEND { $_[0]->STORESIZE($_[1]) }
337 1     1   3 sub SPLICE { splice @{ shift->[0] }, shift, shift, @_ }
  1         7  
338             #>>>
339              
340             =head1 GUTS
341              
342             All objects created and returned by L are blessed REF types. This
343             is what protects the original reference from being blessed into an unwanted
344             package. The C type of the given value is what determines what package the
345             REF is blessed into. HASHes go into C and ARRAYs go into
346             C.
347              
348             The use of the L pragma to overload the dereference operators allows
349             the REF object to still be accesed as HASH refs and ARRAY refs. When these REFs
350             are coerced into their approriate type, they are wrapped in a tie mechanism to
351             retain control over the return of member values.
352              
353             The only way to fully bypass all of this is to manually dereference the REF
354             object:
355              
356             $o = Class::Ref->new({ foo => 1 });
357             $$o->{foo};
358              
359             =head1 CAVEATS
360              
361             When dealing with a wrapped HASH, there is no way to access keys named C
362             and C. They are core methods perl uses to interact with OO values.
363              
364             Accessing HASH members with invalid perl symbols is possible with a little work:
365              
366             my $method = '0) key';
367             $o->$method; # access $o->{'0) key'};
368              
369             =head1 SEE ALSO
370              
371             I've always wanted to have this kind of functionality for hashes that really
372             needed a more formal interface. However, I found myself wanting more from the
373             existing modules out there in the wild. So I borrowed some the great ideas out
374             there and brewed my own implementation to have the level of flexibility that I
375             desire. And if it helps others, that's awesome too.
376              
377             =over 4
378              
379             =item * L
380              
381             Probably the defacto module for creating accessors to a hash. However, it only
382             provides a single layer of encapsulation.
383              
384             =item * L
385              
386             Provides a deeper implementaion but takes (avoids) steps to make the hash
387             read-only.
388              
389             =item * L
390              
391             Also provides a deep implemetation. Goes further to provide access to methods
392             like C and C.
393              
394             =back
395              
396             =head1 AUTHOR
397              
398             William Cox
399              
400             =head1 LICENSE
401              
402             This program is free software; you can redistribute it and/or modify it under
403             the same terms as Perl itself.
404              
405             See L
406              
407             =cut
408              
409             1;