File Coverage

blib/lib/Class/Attrib.pm
Criterion Covered Total %
statement 84 105 80.0
branch 20 32 62.5
condition 3 6 50.0
subroutine 20 21 95.2
pod 2 2 100.0
total 129 166 77.7


line stmt bran cond sub pod time code
1             package Class::Attrib;
2              
3             #
4             # Copyright (C) 2005,2014 by Kevin Cody-Little
5             # All rights reserved.
6             #
7             # See accompanying files COPYING and LGPL-2.1 for license details.
8             #
9              
10             =head1 NAME
11              
12             Class::Attrib - Abstract translucent attribute management.
13              
14             =head1 SYNOPSIS
15              
16             =over
17              
18             =item * Provides an inherited view of attributes.
19              
20             =item * AUTOLOAD's accessor methods for visible attributes only.
21              
22             =item * Supplies a simple way to specify attributes and default values.
23              
24             =back
25              
26             =cut
27              
28 1     1   283 use strict;
  1         2  
  1         21  
29 1     1   4 use warnings;
  1         1  
  1         21  
30              
31 1     1   356 use Storable qw( &dclone );
  1         2053  
  1         80  
32 1     1   284 use Class::Multi 1.04;
  1         1553  
  1         38  
33 1     1   5 use Class::Multi qw( &walk_width &other &otherpkg );
  1         2  
  1         74  
34 1     1   5 use Carp;
  1         2  
  1         37  
35              
36 1     1   4 use vars qw( $VERSION $AUTOLOAD %Attrib );
  1         2  
  1         100  
37              
38             $VERSION = "1.07";
39              
40             # Abstract base class doesn't have any attributes of its own.
41             %Attrib = ();
42              
43              
44             =head1 CLASS ATTRIBUTE DEFINITIONS
45              
46             =head2 Example:
47              
48             package MyApp::MyPackage;
49             use strict;
50              
51             our @ISA = qw( Class::Attrib );
52              
53             our %Attrib = (
54             ClassAttrib => 12345,
55             translucent_attrib => "foo",
56             mandatory_attrib => undef,
57             );
58              
59             1;
60              
61             =head2 Explanation:
62              
63             Attribute definitions are kept in hashes named 'Attrib' in the derived
64             class package.
65              
66             ClassAttrib (a class attribute) only has useful meaning during instantiation
67             of an object, therefore instance data is ignored entirely during accessor calls.
68              
69             translucent_attrib is an instance attribute. Instances inherit their
70             value from their (possibly itself inherited) class default, unless an
71             overriding value has been stored on the object itself.
72              
73             mandatory_attrib has an undefined default, therefore warnings will be issued
74             if the program tries to access the attribute before it sets a value on the
75             object.
76              
77             =head1 CLASS ATTRIBUTE ACCESSOR METHOD
78              
79             =head2 $this->Attrib();
80              
81             Called without arguments, returns a hash containing all known attributes
82             and their default values as inherited from the calling class. (TODO)
83              
84             Returns a hash reference.
85              
86             =head2 $this->Attrib( attribute );
87              
88             Called with one argument, returns the default value of the named attribute
89             as inherited by the calling class.
90              
91             =head2 $this->Attrib( attribute, value );
92              
93             Called with two arguments, overrides an existing attribute default value
94             in the closest class that defined it at compile-time.
95              
96             No mechanism is provided for defining new attributes after compilation.
97              
98             Returns the newly assigned value, for convenience.
99              
100             =cut
101              
102             sub Attrib($;$;$) {
103 8     8 1 13 my $this = shift;
104 8   66     19 my $class = ref( $this ) || $this;
105              
106 8 50       14 unless ( @_ ) {
107 0         0 my %attribs = ();
108 0         0 my ( $Attr, $attr );
109              
110             walk_width {
111 0     0   0 my $pkg = shift;
112              
113             { # scope no strict 'refs'
114 1     1   5 no strict 'refs';
  1         1  
  1         104  
  0         0  
115 0         0 $Attr = \%{$pkg.'::Attrib'};
  0         0  
116             } # end scope
117              
118 0         0 foreach $attr ( keys %$Attr ) {
119             $attribs{$attr} = $Attr->{$attr}
120 0 0       0 unless exists $attribs{$attr};
121             }
122              
123 0         0 undef;
124 0         0 } $class;
125              
126 0         0 return \%attribs;
127             }
128              
129 8         10 my ( $name, $value ) = @_;
130              
131             my $ClassAttrib = walk_width {
132 8     8   209 my $pkg = shift;
133 8         9 my $ClassAttrib;
134              
135             { # scope no strict 'refs'
136 1     1   4 no strict 'refs';
  1         2  
  1         300  
  8         9  
137 8         8 $ClassAttrib = \%{$pkg.'::Attrib'};
  8         17  
138             } # end scope
139              
140 8 50       25 exists $ClassAttrib->{$name}
141             ? $ClassAttrib : undef
142 8         34 } $class;
143              
144 8 50       47 if ( defined $ClassAttrib ) {
145             return @_ > 1
146             ? $ClassAttrib->{$name} = $value
147 8 100       39 : $ClassAttrib->{$name};
148             }
149              
150 0         0 return undef;
151             }
152              
153              
154             =head1 INSTANCE ATTRIBUTE ACCESSOR
155              
156             All three forms act exactly as Attrib when called as a class method.
157              
158             =head2 $this->attrib();
159              
160             Returns a copy of all attribute values specific to the instance.
161              
162             =head2 $self->attrib( attribute );
163              
164             Returns the value of the named attribute. If the instance does not have a
165             corresponding value set, the inherited default value is returned.
166              
167             =head2 $self->attrib( attribute, value );
168              
169             Sets the instance-specific value of an attribute. If the supplied value
170             is 'undef', removes any previously stored instance-specific value.
171              
172             =cut
173              
174             { # private lexicals begin
175              
176             my %values;
177              
178             sub attrib($;$;$) {
179 10     10 1 13 my $self = shift;
180              
181             # class reference, might want to test or change a default
182 10 100       23 return $self->Attrib( @_ ) unless ref $self;
183              
184 9         22 my $index = "$self";
185 9         42 $index =~ s/^.*=//; # ignore class
186              
187             # never return a reference to the real data ;)
188 9 50       19 return dclone( $values{$index} ) unless @_;
189              
190 9         17 my ( $key, $value ) = @_;
191              
192 9 100       18 if ( @_ > 1 ) {
193 3 100       6 if ( defined $value ) {
194 2         6 $values{$index}->{$key} = $value;
195             } else {
196 1         3 delete $values{$index}->{$key};
197             delete $values{$index}
198 1 50       2 unless scalar( %{$values{$index}} );
  1         3  
199             }
200             }
201              
202             return exists $values{$index}->{$key}
203 9 100       39 ? $values{$index}->{$key}
204             : $self->Attrib( $key );
205             }
206              
207             sub DESTROY {
208 1     1   421 my $self = shift;
209              
210 1         3 my $index = "$self";
211 1         35 delete $values{$index};
212              
213             }
214              
215             } # private lexicals end
216              
217             =head1 ATTRIBUTE NAMED ACCESSOR METHODS
218              
219             Each attribute has a corresponding accessor method with the same name.
220             A closure is installed when first called to improve performance.
221              
222             =head2 $this->foo();
223              
224             Equivalent to C<< $this->attrib( 'foo' ); >>
225              
226             =head2 $this->foo( value );
227              
228             Equivalent to C<< $this->attrib( 'foo', $value ); >>
229              
230             =head2 $this->Bar();
231              
232             Equivalent to C<< $this->Attrib( 'Bar' ); >>
233              
234             =cut
235              
236             # AUTOLOAD installs an appropriate closure (anonymous code reference)
237             sub AUTOLOAD {
238 3     3   725 my $this = shift;
239 3         5 my $name = $AUTOLOAD;
240              
241             # strip off the "fully qualified" part of the method name
242 3         17 $name =~ s/.*://;
243              
244             # bail immediately if it's looking for a destructor
245 3 50       11 return if $name eq 'DESTROY';
246              
247             # check to see if the requested attribute exists
248             my $class = walk_width {
249 3     3   103 my $pkg = shift;
250 3         5 my $ClassAttrib;
251             { # scope no strict 'refs'
252 1     1   9 no strict 'refs';
  1         2  
  1         117  
  3         3  
253 3         3 $ClassAttrib = \%{$pkg.'::Attrib'};
  3         8  
254             } # end scope
255              
256 3 50       11 exists $ClassAttrib->{$name}
257             ? $pkg : undef
258 3   33     23 } ref( $this ) || $this;
259              
260             # redispatch; the calling program might not be thinking about us at all
261 3 50       22 unless ( defined $class ) {
262              
263 0 0       0 unless ( $class = otherpkg( $this, 'AUTOLOAD' ) ) {
264 0         0 my $t = $AUTOLOAD; $t =~ s/::[^:]*$//;
  0         0  
265 0         0 confess( __PACKAGE__ . "->AUTOLOAD: ",
266             "No attribute '$name' found via '$t'" )
267             }
268              
269             { # scope no strict refs
270 1     1   5 no strict 'refs';
  1         1  
  1         55  
  0         0  
271 0         0 ${$class.'::AUTOLOAD'} = $AUTOLOAD;
  0         0  
272 0         0 return &{$class.'::AUTOLOAD'}( $this, @_ );
  0         0  
273             } # end scope
274              
275             }
276              
277             # Build fully qualified name --WHERE DATA WAS FOUND--
278             # this keeps code memory to a minimum, while preserving inheritance
279 3         6 my $sym = $class . '::' . $name;
280 3         4 my $ref;
281              
282             # install symbol table reference
283             { # scope no strict refs
284 1     1   5 no strict 'refs';
  1         1  
  1         101  
  3         3  
285              
286             *$sym = $ref = ( $name =~ /^[A-Z]/ )
287 3     3   13 ? sub { return shift->Attrib( $name, @_ ) }
288 3 100   10   19 : sub { return shift->attrib( $name, @_ ) };
  10         27  
289              
290             } # end scope
291              
292             # call newly installed method as a function - avoid method lookup
293 3         7 return &$ref( $this, @_ );
294             }
295              
296              
297             1;
298              
299             =head1 LIMITATIONS
300              
301             Attribute values stored on the instance are actually stored within a
302             Class::Attrib lexical; this avoids collisions and also removes the
303             assumption of a hash. Class::Attrib works perfectly well on scalar
304             and array classes as well. However, this also means that attributes
305             are invisible to serializers.
306              
307             Storing references (blessed or otherwise) in an attribute won't ruffle any
308             feathers in Class::Attrib itself, but could cause exceptions to be thrown
309             if the composite class has a persistence mechanism.
310              
311             Class::Attrib is an abstract class. It contains no constructors, therefore
312             it cannot be instantiated without some impolite bless hackery.
313              
314             =head1 AUTHORS
315              
316             =over
317              
318             =item Kevin Cody-Little
319              
320             =back
321              
322             =cut