File Coverage

blib/lib/Data/Object/AutoWrap.pm
Criterion Covered Total %
statement 55 56 98.2
branch 20 24 83.3
condition 3 3 100.0
subroutine 12 13 92.3
pod n/a
total 90 96 93.7


line stmt bran cond sub pod time code
1             package Data::Object::AutoWrap;
2              
3 2     2   87164 use warnings;
  2         6  
  2         64  
4 2     2   11 use strict;
  2         5  
  2         201  
5 2     2   13 use Carp qw( confess croak );
  2         8  
  2         1320  
6              
7             # use Data::Object::AutoWrap::Hash;
8              
9             $Carp::CarpLevel = 1;
10              
11             =head1 NAME
12              
13             Data::Object::AutoWrap - Autogenerate accessors for R/O object data
14              
15             =head1 VERSION
16              
17             This document describes Data::Object::AutoWrap version 0.02
18              
19             =cut
20              
21             our $VERSION = '0.02';
22              
23             =head1 SYNOPSIS
24              
25             package MyData;
26              
27             # Our data is in $self->{data}
28             use Data::Object::AutoWrap qw( data );
29              
30             sub new {
31             my ( $class, $data ) = @_;
32             bless { data => $data }, $class;
33             }
34              
35             # ... and then later, elsewhere ...
36              
37             my $d = MyData->new( { foo => 1, bar => [ 1, 2, 3 ] } );
38             print $d->foo; # prints "1"
39             print $d->bar( 2 ); # prints "3"
40              
41             =head1 DESCRIPTION
42              
43             This is an experimental module designed to simplify the implementation
44             of read-only objects with value semantics.
45              
46             Objects created using C are bound to a Perl
47             data structure. The automatically provide read only accessor methods for
48             the elements of that structure.
49              
50             =head2 Declaring an autowrapped class
51              
52             As in the example above an autowrapped class is created by adding the line
53              
54             use Data::Object::AutoWrap qw( fieldname );
55              
56             We assume (for now) that the class is hash based and that this hash
57             contains a key called C. The corresponding value is the data
58             structure that will be exposed as the module's interface. The 'root'
59             level of this data structure must itself be a hash - we need the key
60             names so we can generate corresponding methods. Below the root of the
61             data structure any type may be used.
62              
63             If the C is omitted the entire contents of the object's hash
64             will be exposed.
65              
66             =head2 Accessors
67              
68             For each key in the value hash a corresponding read-only accessor is
69             made available. In order for these accessors to be callable the key
70             names must also be valid Perl method names - it's OK to have a key
71             called '*(&!*(&£' but it's rather tricky to call the
72             corresponding accessor.
73              
74             The generated accessors are AUTOLOADed. As a result the bound data
75             structure may be a different shape for each instance of the containing
76             class: the accessors are virtual - they don't actually exist in the
77             module's symbol table.
78              
79             In the following examples we'll assume that we have a
80             C based class called C that gets the
81             data structure to bind to as the argument to its constructor. The code
82             fragment in the synopsis is a suitable implementation of such a class.
83              
84             =head3 Scalar Accessors
85              
86             Any scalars in the hash get an accessor that takes no arguments and
87             returns the corresponding value:
88              
89             my $sc = MyData->new({ flimp_count => 1 });
90             my $fc = $sc->flimp_count; # gets 1
91              
92             An error is raised if arguments are passed to the accessor.
93              
94             =head3 Hash Accessors
95              
96             Any nested hashes in the data structure get accessors that return
97             recursively wrapped hashes. That means that this will work:
98              
99             my $hc = MyData->new(
100             {
101             person => {
102             name => 'Andy',
103             job => 'Perl baiter',
104             },
105             }
106             );
107              
108             print $hc->person->job; # prints "Perl baiter"
109              
110             =head3 Array accessors
111              
112             The accessor for array values accepts an optional subscript:
113              
114             my $ac = MyData->new( { list => [ 12, 27, 36, 43, ] } );
115             my $third = $ac->list( 3 ); # gets 36
116              
117             Called in a list context with no arguments the accessor for an array
118             returns that array:
119              
120             my @list = $ac->list; # gets the whole list
121              
122             =head3 Accessors for other types
123              
124             Anything that's not an array or a hash gets the scalar accessor - so
125             things like globs will also be accessible.
126              
127             =head3 Accessor parameters
128              
129             Array and hash accessors can accept more than one parameter. For example
130             if you have an array of arrays you can subscript into it like this:
131              
132             my $gc = MyData->new(
133             {
134             grid => [
135             [ 0, 1, 2, 3 ],
136             [ 4, 5, 6, 7 ],
137             [ 8, 9, 10, 11 ],
138             [ 12, 13, 14, 15 ],
139             ],
140             }
141             );
142              
143             my $dot = $gc->grid( 3, 4 ); # gets 11
144              
145             In general any parameters specify a path through the data structure:
146              
147             my $hc = MyData->new(
148             {
149             deep => {
150             smash => 'pumpkins',
151             eviscerate => [ 'a', 'b', 'c' ],
152             lament => { fine => 'camels' }
153             }
154             }
155             );
156              
157             print $hc->deep( 'smash' ); # 'pumpkins'
158             print $hc->deep( 'eviscerate', 1 ); # 'b'
159             print $hc->deep( 'lament', 'fine' ); # 'camels'
160             print $hc->deep->lament->fine; # also 'camels'
161             print $hc->deep( 'lament' )->fine; # 'camels' again
162             print $hc->deep->lament( 'fine' ); # more 'camels'
163              
164             =head1 CAVEATS
165              
166             This is experimental code. Don't be using it in, for example, a life
167             support system, ATM or space shuttle.
168              
169             =head2 AUTOLOAD
170              
171             C injects an C handler into the
172             package from which it is used. It doesn't care about any existing
173             C or any that might be provided by a superclass. Given that
174             it's designed for the implementation of simple, value like objects this
175             shouldn't be a problem - but you've been warned.
176              
177             =head2 Performance
178              
179             It's slow. Slow as mollasses in an igloo. Last time I checked the
180             autogenerated accessors are something like fifteen times slower than the
181             simplest hand wrought accessor.
182              
183             This can probably be improved.
184              
185             =cut
186              
187             sub _make_value_handler {
188 67     67   109 my ( $class, $value ) = @_;
189 67 100       183 if ( 'HASH' eq ref $value ) {
    100          
190             # Delay loading so we're compiled before wrapper
191             # attempts to use us.
192 18         1077 eval 'require Data::Object::AutoWrap::Hash';
193 18 50       69 die $@ if $@;
194             return sub {
195 18     18   25 my $self = shift;
196 18 100       39 if ( @_ ) {
197 2         3 my $key = shift;
198 2         7 return $class->_make_value_handler( $value->{$key} )
199             ->( $self, @_ );
200             }
201             else {
202 16         58 return Data::Object::AutoWrap::Hash->new( $value );
203             }
204 18         101 };
205             }
206             elsif ( 'ARRAY' eq ref $value ) {
207             return sub {
208 20     20   26 my $self = shift;
209             # Special case for ARRAY refs because we can't turn an array
210             # ref into an object with an accessor; array items are
211             # always accessed by subscripting into the parent object.
212 10 100       32 return map {
213 20 100 100     63 'ARRAY' eq ref $_
214             ? $_
215             : $class->_make_value_handler( $_ )->( $self )
216             } @$value
217             if wantarray && @_ == 0;
218 17 50       34 croak "Array accessor needs an index in scalar context"
219             unless @_;
220 17         23 my $idx = shift;
221 17         44 return $class->_make_value_handler( $value->[$idx] )
222             ->( $self, @_ );
223 20         125 };
224             }
225             else {
226             return sub {
227 27     27   31 my $self = shift;
228 27 50       61 croak "Scalar accessor takes no argument"
229             if @_;
230 27         137 return $value;
231 29         146 };
232             }
233             }
234              
235             sub import {
236 3     3   20 my $class = shift;
237 3         8 my $pkg = caller;
238              
239 3         5 my $get_data;
240 3 100       12 if ( @_ ) {
241 2         5 my $field = shift;
242             # TODO: Allow a closure here so objects can be promises
243 2     42   12 $get_data = sub { shift->{$field} };
  42         88  
244             }
245             else {
246 1     0   4 $get_data = sub { shift };
  0         0  
247             }
248              
249 2     2   13 no strict 'refs';
  2         4  
  2         660  
250 3         20 *{"${pkg}::can"} = sub {
251 42     42   10745 my ( $self, $method ) = @_;
252 42         77 my $data = $get_data->( $self );
253             return
254 42 100       219 exists $data->{$method}
255             ? $class->_make_value_handler( $data->{$method} )
256             : $pkg->SUPER::can( $method );
257 3         14 };
258              
259 3         6 our $AUTOLOAD;
260 3         4306 *{"${pkg}::AUTOLOAD"} = sub {
261 38     38   2544 my $self = shift;
262 38         158 ( my $field = $AUTOLOAD ) =~ s/.*://;
263 38 50       165 return if $field eq 'DESTROY';
264 38 100       81 if ( my $code = $self->can( $field ) ) {
265 37         88 return $self->$code( @_ );
266             }
267              
268 1         135 confess "Undefined subroutine &$AUTOLOAD called";
269 3         12 };
270             }
271              
272             1;
273              
274             __END__