Commit | Line | Data |
3fea05b9 |
1 | package Class::Data::Inheritable; |
2 | |
3 | use strict qw(vars subs); |
4 | use vars qw($VERSION); |
5 | $VERSION = '0.08'; |
6 | |
7 | sub mk_classdata { |
8 | my ($declaredclass, $attribute, $data) = @_; |
9 | |
10 | if( ref $declaredclass ) { |
11 | require Carp; |
12 | Carp::croak("mk_classdata() is a class method, not an object method"); |
13 | } |
14 | |
15 | my $accessor = sub { |
16 | my $wantclass = ref($_[0]) || $_[0]; |
17 | |
18 | return $wantclass->mk_classdata($attribute)->(@_) |
19 | if @_>1 && $wantclass ne $declaredclass; |
20 | |
21 | $data = $_[1] if @_>1; |
22 | return $data; |
23 | }; |
24 | |
25 | my $alias = "_${attribute}_accessor"; |
26 | *{$declaredclass.'::'.$attribute} = $accessor; |
27 | *{$declaredclass.'::'.$alias} = $accessor; |
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 same terms as Perl itself. |
146 | |
147 | =head1 SEE ALSO |
148 | |
149 | L<perltooc> has a very elaborate discussion of class data in Perl. |
150 | |