File Coverage

blib/lib/Class/Data/Inheritable.pm
Criterion Covered Total %
statement 20 20 100.0
branch 6 6 100.0
condition 5 6 83.3
subroutine 4 4 100.0
pod 1 1 100.0
total 36 37 97.3


line stmt bran cond sub pod time code
1             package Class::Data::Inheritable;
2              
3 2     2   34 use strict qw(vars subs);
  2         24  
  2         33  
4 2     2   31 use vars qw($VERSION);
  2         18  
  2         29  
5             $VERSION = '0.06';
6              
7             sub mk_classdata {
8 5     5 1 56     my ($declaredclass, $attribute, $data) = @_;
9              
10 5 100       52     if( ref $declaredclass ) {
11 1         18         require Carp;
12 1         14         Carp::croak("mk_classdata() is a class method, not an object method");
13                 }
14              
15                 my $accessor = sub {
16 15   66 15   204         my $wantclass = ref($_[0]) || $_[0];
17              
18 15 100 100     190         return $wantclass->mk_classdata($attribute)->(@_)
19                       if @_>1 && $wantclass ne $declaredclass;
20              
21 13 100       135         $data = $_[1] if @_>1;
22 13         175         return $data;
23 4         129     };
24              
25 4         41     my $alias = "_${attribute}_accessor";
26 4         32     *{$declaredclass.'::'.$attribute} = $accessor;
  4         52  
27 4         32     *{$declaredclass.'::'.$alias} = $accessor;
  4         87  
28             }
29              
30             1;
31              
32             __END__
33            
34             =head1 NAME
35            
36             Class::Data::Inheritable - Inheritable, overridable class data
37            
38             =head1 SYNOPSIS
39            
40             package Stuff;
41             use base qw(Class::Data::Inheritable);
42            
43             # Set up DataFile as inheritable class data.
44             Stuff->mk_classdata('DataFile');
45            
46             # Declare the location of the data file for this class.
47             Stuff->DataFile('/etc/stuff/data');
48            
49             # Or, all in one shot:
50             Stuff->mk_classdata(DataFile => '/etc/stuff/data');
51            
52             =head1 DESCRIPTION
53            
54             Class::Data::Inheritable is for creating accessor/mutators to class
55             data. That is, if you want to store something about your class as a
56             whole (instead of about a single object). This data is then inherited
57             by your subclasses and can be overriden.
58            
59             For example:
60            
61             Pere::Ubu->mk_classdata('Suitcase');
62            
63             will generate the method Suitcase() in the class Pere::Ubu.
64            
65             This new method can be used to get and set a piece of class data.
66            
67             Pere::Ubu->Suitcase('Red');
68             $suitcase = Pere::Ubu->Suitcase;
69            
70             The interesting part happens when a class inherits from Pere::Ubu:
71            
72             package Raygun;
73             use base qw(Pere::Ubu);
74            
75             # Raygun's suitcase is Red.
76             $suitcase = Raygun->Suitcase;
77            
78             Raygun inherits its Suitcase class data from Pere::Ubu.
79            
80             Inheritance of class data works analogous to method inheritance. As
81             long as Raygun does not "override" its inherited class data (by using
82             Suitcase() to set a new value) it will continue to use whatever is set
83             in Pere::Ubu and inherit further changes:
84            
85             # Both Raygun's and Pere::Ubu's suitcases are now Blue
86             Pere::Ubu->Suitcase('Blue');
87            
88             However, should Raygun decide to set its own Suitcase() it has now
89             "overridden" Pere::Ubu and is on its own, just like if it had
90             overriden a method:
91            
92             # Raygun has an orange suitcase, Pere::Ubu's is still Blue.
93             Raygun->Suitcase('Orange');
94            
95             Now that Raygun has overridden Pere::Ubu futher changes by Pere::Ubu
96             no longer effect Raygun.
97            
98             # Raygun still has an orange suitcase, but Pere::Ubu is using Samsonite.
99             Pere::Ubu->Suitcase('Samsonite');
100            
101             =head1 Methods
102            
103             =head2 mk_classdata
104            
105             Class->mk_classdata($data_accessor_name);
106             Class->mk_classdata($data_accessor_name => $value);
107            
108             This is a class method used to declare new class data accessors.
109             A new accessor will be created in the Class using the name from
110             $data_accessor_name, and optionally initially setting it to the given
111             value.
112            
113             To facilitate overriding, mk_classdata creates an alias to the
114             accessor, _field_accessor(). So Suitcase() would have an alias
115             _Suitcase_accessor() that does the exact same thing as Suitcase().
116             This is useful if you want to alter the behavior of a single accessor
117             yet still get the benefits of inheritable class data. For example.
118            
119             sub Suitcase {
120             my($self) = shift;
121             warn "Fashion tragedy" if @_ and $_[0] eq 'Plaid';
122            
123             $self->_Suitcase_accessor(@_);
124             }
125            
126             =head1 AUTHOR
127            
128             Original code by Damian Conway.
129            
130             Maintained by Michael G Schwern until September 2005.
131            
132             Now maintained by Tony Bowden.
133            
134             =head1 BUGS and QUERIES
135            
136             Please direct all correspondence regarding this module to:
137             bug-Class-Data-Inheritable@rt.cpan.org
138            
139             =head1 COPYRIGHT and LICENSE
140            
141             Copyright (c) 2000-2005, Damian Conway and Michael G Schwern.
142             All Rights Reserved.
143            
144             This module is free software. It may be used, redistributed and/or
145             modified under the terms of the Perl Artistic License (see
146             http://www.perl.com/perl/misc/Artistic.html)
147            
148             =head1 SEE ALSO
149            
150             L<perltootc> has a very elaborate discussion of class data in Perl.
151            
152