File Coverage

blib/lib/Class/Accessor.pm
Criterion Covered Total %
statement 96 102 94.1
branch 26 34 76.5
condition 20 33 60.6
subroutine 23 23 100.0
pod 12 14 85.7
total 177 206 85.9


line stmt bran cond sub pod time code
1             package Class::Accessor;
2             require 5.00502;
3 5     5   83 use strict;
  5         1916  
  5         88  
4             $Class::Accessor::VERSION = '0.30';
5              
6             =head1 NAME
7            
8             Class::Accessor - Automated accessor generation
9            
10             =head1 SYNOPSIS
11            
12             package Employee;
13             use base qw(Class::Accessor);
14             Employee->mk_accessors(qw(name role salary));
15            
16             # Meanwhile, in a nearby piece of code!
17             # Class::Accessor provides new().
18             my $mp = Foo->new({ name => "Marty", role => "JAPH" });
19            
20             my $job = $mp->role; # gets $mp->{role}
21             $mp->salary(400000); # sets $mp->{salary} = 400000 (I wish)
22            
23             # like my @info = @{$mp}{qw(name role)}
24             my @info = $mp->get(qw(name role));
25            
26             # $mp->{salary} = 400000
27             $mp->set('salary', 400000);
28            
29            
30             =head1 DESCRIPTION
31            
32             This module automagically generates accessors/mutators for your class.
33            
34             Most of the time, writing accessors is an exercise in cutting and
35             pasting. You usually wind up with a series of methods like this:
36            
37             sub name {
38             my $self = shift;
39             if(@_) {
40             $self->{name} = $_[0];
41             }
42             return $self->{name};
43             }
44            
45             sub salary {
46             my $self = shift;
47             if(@_) {
48             $self->{salary} = $_[0];
49             }
50             return $self->{salary};
51             }
52            
53             # etc...
54            
55             One for each piece of data in your object. While some will be unique,
56             doing value checks and special storage tricks, most will simply be
57             exercises in repetition. Not only is it Bad Style to have a bunch of
58             repetitious code, but its also simply not lazy, which is the real
59             tragedy.
60            
61             If you make your module a subclass of Class::Accessor and declare your
62             accessor fields with mk_accessors() then you'll find yourself with a
63             set of automatically generated accessors which can even be
64             customized!
65            
66             The basic set up is very simple:
67            
68             package My::Class;
69             use base qw(Class::Accessor);
70             My::Class->mk_accessors( qw(foo bar car) );
71            
72             Done. My::Class now has simple foo(), bar() and car() accessors
73             defined.
74            
75             =head2 What Makes This Different?
76            
77             What makes this module special compared to all the other method
78             generating modules (L<"SEE ALSO">)? By overriding the get() and set()
79             methods you can alter the behavior of the accessors class-wide. Also,
80             the accessors are implemented as closures which should cost a bit less
81             memory than most other solutions which generate a new method for each
82             accessor.
83            
84            
85             =head1 METHODS
86            
87             =head2 new
88            
89             my $obj = Class->new;
90             my $obj = $other_obj->new;
91            
92             my $obj = Class->new(\%fields);
93             my $obj = $other_obj->new(\%fields);
94            
95             Class::Accessor provides a basic constructor. It generates a
96             hash-based object and can be called as either a class method or an
97             object method.
98            
99             It takes an optional %fields hash which is used to initialize the
100             object (handy if you use read-only accessors). The fields of the hash
101             correspond to the names of your accessors, so...
102            
103             package Foo;
104             use base qw(Class::Accessor);
105             Foo->mk_accessors('foo');
106            
107             my $obj = Class->new({ foo => 42 });
108             print $obj->foo; # 42
109            
110             however %fields can contain anything, new() will shove them all into
111             your object. Don't like it? Override it.
112            
113             =cut
114              
115             sub new {
116 10     10 1 326     my($proto, $fields) = @_;
117 10   33     213     my($class) = ref $proto || $proto;
118              
119 10 100       112     $fields = {} unless defined $fields;
120              
121             # make a copy of $fields.
122 10         173     bless {%$fields}, $class;
123             }
124              
125             =head2 mk_accessors
126            
127             Class->mk_accessors(@fields);
128            
129             This creates accessor/mutator methods for each named field given in
130             @fields. Foreach field in @fields it will generate two accessors.
131             One called "field()" and the other called "_field_accessor()". For
132             example:
133            
134             # Generates foo(), _foo_accessor(), bar() and _bar_accessor().
135             Class->mk_accessors(qw(foo bar));
136            
137             See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
138             for details.
139            
140             =cut
141              
142             sub mk_accessors {
143 13     13 1 670     my($self, @fields) = @_;
144              
145 13         223     $self->_mk_accessors('rw', @fields);
146             }
147              
148              
149             {
150 5     5   81     no strict 'refs';
  5         45  
  5         67  
151              
152                 sub _mk_accessors {
153 33     33   359         my($self, $access, @fields) = @_;
154 33   33     2239         my $class = ref $self || $self;
155 33   100     424         my $ra = $access eq 'rw' || $access eq 'ro';
156 33   100     386         my $wa = $access eq 'rw' || $access eq 'wo';
157              
158 33         305         foreach my $field (@fields) {
159 51         645             my $accessor_name = $self->accessor_name_for($field);
160 51         768             my $mutator_name = $self->mutator_name_for($field);
161 51 100 66     738             if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
162 3         60                 $self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
163                         }
164 51 100       521             if ($accessor_name eq $mutator_name) {
165 33         333                 my $accessor;
166 33 100 100     407                 if ($ra && $wa) {
    100          
167 19         271                     $accessor = $self->make_accessor($field);
168                             } elsif ($ra) {
169 7         97                     $accessor = $self->make_ro_accessor($field);
170                             } else {
171 7         128                     $accessor = $self->make_wo_accessor($field);
172                             }
173 33 100       280                 unless (defined &{"${class}::$accessor_name"}) {
  33         424  
174 27         215                     *{"${class}::$accessor_name"} = $accessor;
  27         525  
175                             }
176 33 50       1273                 if ($accessor_name eq $field) {
177             # the old behaviour
178 33         2173                     my $alias = "_${field}_accessor";
179 33 50       349                     *{"${class}::$alias"} = $accessor unless defined &{"${class}::$alias"};
  33         538  
  33         425  
180                             }
181                         } else {
182 18 100 66     175                 if ($ra and not defined &{"${class}::$accessor_name"}) {
  12         180  
183 12         250                     *{"${class}::$accessor_name"} = $self->make_ro_accessor($field);
  12         202  
184                             }
185 18 100 66     247                 if ($wa and not defined &{"${class}::$mutator_name"}) {
  12         172  
186 12         171                     *{"${class}::$mutator_name"} = $self->make_wo_accessor($field);
  12         207  
187                             }
188                         }
189                     }
190                 }
191              
192                 sub follow_best_practice {
193 3     3 1 28         my($self) = @_;
194 3   33     44         my $class = ref $self || $self;
195 3         29         *{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
  3         45  
196 3         29         *{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
  3         46  
197                 }
198              
199             }
200              
201             =head2 mk_ro_accessors
202            
203             Class->mk_ro_accessors(@read_only_fields);
204            
205             Same as mk_accessors() except it will generate read-only accessors
206             (ie. true accessors). If you attempt to set a value with these
207             accessors it will throw an exception. It only uses get() and not
208             set().
209            
210             package Foo;
211             use base qw(Class::Accessor);
212             Class->mk_ro_accessors(qw(foo bar));
213            
214             # Let's assume we have an object $foo of class Foo...
215             print $foo->foo; # ok, prints whatever the value of $foo->{foo} is
216             $foo->foo(42); # BOOM! Naughty you.
217            
218            
219             =cut
220              
221             sub mk_ro_accessors {
222 10     10 1 277     my($self, @fields) = @_;
223              
224 10         248     $self->_mk_accessors('ro', @fields);
225             }
226              
227             =head2 mk_wo_accessors
228            
229             Class->mk_wo_accessors(@write_only_fields);
230            
231             Same as mk_accessors() except it will generate write-only accessors
232             (ie. mutators). If you attempt to read a value with these accessors
233             it will throw an exception. It only uses set() and not get().
234            
235             B<NOTE> I'm not entirely sure why this is useful, but I'm sure someone
236             will need it. If you've found a use, let me know. Right now its here
237             for orthoginality and because its easy to implement.
238            
239             package Foo;
240             use base qw(Class::Accessor);
241             Class->mk_wo_accessors(qw(foo bar));
242            
243             # Let's assume we have an object $foo of class Foo...
244             $foo->foo(42); # OK. Sets $self->{foo} = 42
245             print $foo->foo; # BOOM! Can't read from this accessor.
246            
247             =cut
248              
249             sub mk_wo_accessors {
250 10     10 1 211     my($self, @fields) = @_;
251              
252 10         135     $self->_mk_accessors('wo', @fields);
253             }
254              
255             =head1 DETAILS
256            
257             An accessor generated by Class::Accessor looks something like
258             this:
259            
260             # Your foo may vary.
261             sub foo {
262             my($self) = shift;
263             if(@_) { # set
264             return $self->set('foo', @_);
265             }
266             else {
267             return $self->get('foo');
268             }
269             }
270            
271             Very simple. All it does is determine if you're wanting to set a
272             value or get a value and calls the appropriate method.
273             Class::Accessor provides default get() and set() methods which
274             your class can override. They're detailed later.
275            
276             =head2 follow_best_practice
277            
278             In Damian's Perl Best Practices book he recommends separate get and set methods
279             with the prefix set_ and get_ to make it explicit what you intend to do. If you
280             want to create those accessor methods instead of the default ones, call:
281            
282             __PACKAGE__->follow_best_practice
283            
284             =head2 accessor_name_for / mutator_name_for
285            
286             You may have your own crazy ideas for the names of the accessors, so you can
287             make those happen by overriding C<accessor_name_for> and C<mutator_name_for> in
288             your subclass. (I copied that idea from Class::DBI.)
289            
290             =cut
291              
292             sub best_practice_accessor_name_for {
293 9     9 0 85     my ($class, $field) = @_;
294 9         93     return "get_$field";
295             }
296              
297             sub best_practice_mutator_name_for {
298 9     9 0 82     my ($class, $field) = @_;
299 9         89     return "set_$field";
300             }
301              
302             sub accessor_name_for {
303 33     33 1 307     my ($class, $field) = @_;
304 33         329     return $field;
305             }
306              
307             sub mutator_name_for {
308 33     33 1 320     my ($class, $field) = @_;
309 33         1205     return $field;
310             }
311              
312             =head2 Modifying the behavior of the accessor
313            
314             Rather than actually modifying the accessor itself, it is much more
315             sensible to simply override the two key methods which the accessor
316             calls. Namely set() and get().
317            
318             If you -really- want to, you can override make_accessor().
319            
320             =head2 set
321            
322             $obj->set($key, $value);
323             $obj->set($key, @values);
324            
325             set() defines how generally one stores data in the object.
326            
327             override this method to change how data is stored by your accessors.
328            
329             =cut
330              
331             sub set {
332 7     7 1 85     my($self, $key) = splice(@_, 0, 2);
333              
334 7 50       218     if(@_ == 1) {
    0          
335 7         91         $self->{$key} = $_[0];
336                 }
337                 elsif(@_ > 1) {
338 0         0         $self->{$key} = [@_];
339                 }
340                 else {
341 0         0         $self->_croak("Wrong number of arguments received");
342                 }
343             }
344              
345             =head2 get
346            
347             $value = $obj->get($key);
348             @values = $obj->get(@keys);
349            
350             get() defines how data is retreived from your objects.
351            
352             override this method to change how it is retreived.
353            
354             =cut
355              
356             sub get {
357 14     14 1 131     my $self = shift;
358              
359 14 50       177     if(@_ == 1) {
    0          
360 14         214         return $self->{$_[0]};
361                 }
362                 elsif( @_ > 1 ) {
363 0         0         return @{$self}{@_};
  0         0  
364                 }
365                 else {
366 0         0         $self->_croak("Wrong number of arguments received");
367                 }
368             }
369              
370             =head2 make_accessor
371            
372             $accessor = Class->make_accessor($field);
373            
374             Generates a subroutine reference which acts as an accessor for the given
375             $field. It calls get() and set().
376            
377             If you wish to change the behavior of your accessors, try overriding
378             get() and set() before you start mucking with make_accessor().
379            
380             =cut
381              
382             sub make_accessor {
383 7     7 1 67     my ($class, $field) = @_;
384              
385             # Build a closure around $field.
386                 return sub {
387 10     10   163         my $self = shift;
388              
389 10 100       96         if(@_) {
390 3         38             return $self->set($field,