File Coverage

blib/lib/Class/Data/Accessor.pm
Criterion Covered Total %
statement 30 33 90.9
branch 13 14 92.9
condition 5 6 83.3
subroutine 6 7 85.7
pod 2 2 100.0
total 56 62 90.3


line stmt bran cond sub pod time code
1             package Class::Data::Accessor;
2 2     2   34 use strict qw(vars subs);
  2         23  
  2         32  
3 2     2   43 use Carp;
  2         19  
  2         103  
4 2     2   89 use vars qw($VERSION);
  2         21  
  2         32  
5             $VERSION = '0.03';
6              
7             sub mk_classaccessor {
8 7     7 1 102     my ($declaredclass, $attribute, $data) = @_;
9              
10 7 100       90     if( ref $declaredclass ) {
11 2         26         croak("mk_classaccessor() is a class method, not an object method");
12                 }
13              
14 5 100       52     if( $attribute eq 'DESTROY' ) {
15 1         18         carp("Having a data accessor named DESTROY in '$declaredclass' is unwise.");
16                 }
17              
18                 my $accessor = sub {
19 17 100   17   655         if (ref $_[0]) {
20 2 100       70           return $_[0]->{$attribute} = $_[1] if @_ > 1;
21 1 50       14           return $_[0]->{$attribute} if exists $_[0]->{$attribute};
22                     }
23              
24 16   66     324         my $wantclass = ref($_[0]) || $_[0];
25              
26 16 100 100     205         return $wantclass->mk_classaccessor($attribute)->(@_)
27                       if @_>1 && $wantclass ne $declaredclass;
28              
29 14 100       423         $data = $_[1] if @_>1;
30 14         187         return $data;
31 5         100     };
32              
33 2     2   44     no warnings qw/redefine/;
  2         19  
  2         39  
34 5         55     my $alias = "_${attribute}_accessor";
35 5         43     *{$declaredclass.'::'.$attribute} = $accessor;
  5         67  
36 5         41     *{$declaredclass.'::'.$alias} = $accessor;
  5         76  
37             }
38              
39             sub mk_classaccessors {
40 0     0 1       my ($declaredclass, @attributes) = @_;
41              
42 0               foreach my $attribute (@attributes) {
43 0                   $declaredclass->mk_classaccessor($attribute);
44                 }
45             };
46              
47             __END__
48            
49             =head1 NAME
50            
51             Class::Data::Accessor - Inheritable, overridable class and instance data accessor creation
52            
53             =head1 SYNOPSIS
54            
55             package Stuff;
56             use base qw(Class::Data::Accessor);
57            
58             # Set up DataFile as inheritable class data.
59             Stuff->mk_classaccessor('DataFile');
60            
61             # Declare the location of the data file for this class.
62             Stuff->DataFile('/etc/stuff/data');
63            
64             # Or, all in one shot:
65             Stuff->mk_classaccessor(DataFile => '/etc/stuff/data');
66            
67            
68             Stuff->DataFile; # returns /etc/stuff/data
69            
70             my $stuff = Stuff->new; # your new, not ours
71            
72             $stuff->DataFile; # returns /etc/stuff/data
73            
74             $stuff->DataFile('/etc/morestuff'); # sets it on the object
75            
76             Stuff->DataFile; # still returns /etc/stuff/data
77            
78             =head1 DESCRIPTION
79            
80             Class::Data::Accessor is the marriage of L<Class::Accessor> and
81             L<Class::Data::Inheritable> into a single module. It is used for creating
82             accessors to class data that overridable in subclasses as well as in
83             class instances.
84            
85             For example:
86            
87             Pere::Ubu->mk_classaccessor('Suitcase');
88            
89             will generate the method Suitcase() in the class Pere::Ubu.
90            
91             This new method can be used to get and set a piece of class data.
92            
93             Pere::Ubu->Suitcase('Red');
94             $suitcase = Pere::Ubu->Suitcase;
95            
96             Taking this one step further, you can make a subclass that inherits from
97             Pere::Ubu:
98            
99             package Raygun;
100             use base qw(Pere::Ubu);
101            
102             # Raygun's suitcase is Red.
103             $suitcase = Raygun->Suitcase;
104            
105             Raygun inherits its Suitcase class data from Pere::Ubu.
106            
107             Inheritance of class data works analogous to method inheritance. As
108             long as Raygun does not "override" its inherited class data (by using
109             Suitcase() to set a new value) it will continue to use whatever is set
110             in Pere::Ubu and inherit further changes:
111            
112             # Both Raygun's and Pere::Ubu's suitcases are now Blue
113             Pere::Ubu->Suitcase('Blue');
114            
115             However, should Raygun decide to set its own Suitcase() it has now
116             "overridden" Pere::Ubu and is on its own, just like if it had
117             overridden a method:
118            
119             # Raygun has an orange suitcase, Pere::Ubu's is still Blue.
120             Raygun->Suitcase('Orange');
121            
122             Now that Raygun has overridden Pere::Ubu, further changes by Pere::Ubu
123             no longer effect Raygun.
124            
125             # Raygun still has an orange suitcase, but Pere::Ubu is using Samsonite.
126             Pere::Ubu->Suitcase('Samsonite');
127            
128             You can also override this class data on a per-object basis.
129             If $obj isa Pere::Ubu then
130            
131             $obj->Suitcase; # will return Samsonite
132            
133             $obj->Suitcase('Purple'); # will set Suitcase *for this object only*
134            
135             And after you've done that,
136            
137             $obj->Suitcase; # will return Purple
138            
139             but
140            
141             Pere::Ubu->Suitcase; # will still return Samsonite
142            
143             If you don't want this behaviour use L<Class::Data::Inheritable> instead.
144            
145             C<mk_classaccessor> will die if used as an object method instead of as a
146             class method.
147            
148             =head1 METHODS
149            
150             =head2 mk_classaccessor
151            
152             Class->mk_classaccessor($data_accessor_name);
153             Class->mk_classaccessor($data_accessor_name => $value);
154            
155             This is a class method used to declare new class data accessors.
156             A new accessor will be created in the Class using the name from
157             $data_accessor_name, and optionally initially setting it to the given
158             value.
159            
160             To facilitate overriding, mk_classaccessor creates an alias to the
161             accessor, _field_accessor(). So Suitcase() would have an alias
162             _Suitcase_accessor() that does the exact same thing as Suitcase().
163             This is useful if you want to alter the behavior of a single accessor
164             yet still get the benefits of inheritable class data. For example.
165            
166             sub Suitcase {
167             my($self) = shift;
168             warn "Fashion tragedy" if @_ and $_[0] eq 'Plaid';
169            
170             $self->_Suitcase_accessor(@_);
171             }
172            
173             Overriding accessors does not work in the same class as you declare
174             the accessor in. It only works in subclasses due to the fact that
175             subroutines are loaded at compile time and accessors are loaded at
176             runtime, thus overriding any subroutines with the same name in the
177             same class.
178            
179             =head2 mk_classaccessors(@accessornames)
180            
181             Takes a list of names and generates an accessor for each name in the list using
182             C<mk_classaccessor>.
183            
184             =head1 AUTHORS
185            
186             Based on the creative stylings of Damian Conway, Michael G Schwern,
187             Tony Bowden (Class::Data::Inheritable) and Michael G Schwern, Marty Pauley
188             (Class::Accessor).
189            
190             Coded by Matt S Trout
191             Tweaks by Christopher H. Laco.
192            
193             =head1 BUGS and QUERIES
194            
195             If your object isn't hash-based, this will currently break. My modifications
196             aren't exactly sophisticated so far.
197            
198             mstrout@cpan.org or bug me on irc.perl.org, nick mst
199             claco@cpan.org or irc.perl.org, nick claco
200            
201             =head1 LICENSE
202            
203             This module is free software. It may be used, redistributed and/or
204             modified under the terms of the Perl Artistic License (see
205             http://www.perl.com/perl/misc/Artistic.html)
206            
207             =head1 SEE ALSO
208            
209             L<perltootc> has a very elaborate discussion of class data in Perl.
210             L<Class::Accessor>, L<Class::Data::Inheritable>
211            
212             =cut
213            
214             1;
215