Commit | Line | Data |
963a69a5 |
1 | package Class::Accessor::Grouped; |
2 | use strict; |
3 | use warnings; |
0fea2bfb |
4 | use Carp; |
e6f2a0fd |
5 | use Class::ISA; |
6 | use Scalar::Util qw/blessed reftype/; |
963a69a5 |
7 | use vars qw($VERSION); |
8 | |
c46050d3 |
9 | $VERSION = '0.02'; |
963a69a5 |
10 | |
11 | =head1 NAME |
12 | |
1ad8d8c6 |
13 | Class::Accessor::Grouped - Lets you build groups of accessors |
963a69a5 |
14 | |
15 | =head1 SYNOPSIS |
16 | |
17 | =head1 DESCRIPTION |
18 | |
19 | This class lets you build groups of accessors that will call different |
20 | getters and setters. |
21 | |
22 | =head1 METHODS |
23 | |
24 | =head2 mk_group_accessors |
25 | |
26 | =over 4 |
27 | |
28 | =item Arguments: $group, @fieldspec |
29 | |
30 | Returns: none |
31 | |
32 | =back |
33 | |
34 | Creates a set of accessors in a given group. |
35 | |
36 | $group is the name of the accessor group for the generated accessors; they |
37 | will call get_$group($field) on get and set_$group($field, $value) on set. |
38 | |
39 | @fieldspec is a list of field/accessor names; if a fieldspec is a scalar |
40 | this is used as both field and accessor name, if a listref it is expected to |
41 | be of the form [ $accessor, $field ]. |
42 | |
43 | =cut |
44 | |
45 | sub mk_group_accessors { |
46 | my ($self, $group, @fields) = @_; |
47 | |
48 | $self->_mk_group_accessors('make_group_accessor', $group, @fields); |
49 | return; |
50 | } |
51 | |
52 | |
53 | { |
54 | no strict 'refs'; |
55 | no warnings 'redefine'; |
56 | |
57 | sub _mk_group_accessors { |
58 | my($self, $maker, $group, @fields) = @_; |
59 | my $class = ref $self || $self; |
60 | |
61 | # So we don't have to do lots of lookups inside the loop. |
62 | $maker = $self->can($maker) unless ref $maker; |
63 | |
64 | foreach my $field (@fields) { |
65 | if( $field eq 'DESTROY' ) { |
66 | carp("Having a data accessor named DESTROY in ". |
67 | "'$class' is unwise."); |
68 | } |
69 | |
70 | my $name = $field; |
71 | |
72 | ($name, $field) = @$field if ref $field; |
73 | |
74 | my $accessor = $self->$maker($group, $field); |
75 | my $alias = "_${name}_accessor"; |
76 | |
77 | #warn "$class $group $field $alias"; |
78 | |
79 | *{$class."\:\:$name"} = $accessor; |
80 | #unless defined &{$class."\:\:$field"} |
81 | |
82 | *{$class."\:\:$alias"} = $accessor; |
83 | #unless defined &{$class."\:\:$alias"} |
84 | } |
85 | } |
86 | } |
87 | |
88 | =head2 mk_group_ro_accessors |
89 | |
90 | =over 4 |
91 | |
92 | =item Arguments: $group, @fieldspec |
93 | |
94 | Returns: none |
95 | |
96 | =back |
97 | |
98 | Creates a set of read only accessors in a given group. Identical to |
99 | <L:/mk_group_accessors> but accessors will throw an error if passed a value |
100 | rather than setting the value. |
101 | |
102 | =cut |
103 | |
104 | sub mk_group_ro_accessors { |
105 | my($self, $group, @fields) = @_; |
106 | |
107 | $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields); |
108 | } |
109 | |
110 | =head2 mk_group_wo_accessors |
111 | |
112 | =over 4 |
113 | |
114 | =item Arguments: $group, @fieldspec |
115 | |
116 | Returns: none |
117 | |
118 | =back |
119 | |
120 | Creates a set of write only accessors in a given group. Identical to |
121 | <L:/mk_group_accessors> but accessors will throw an error if not passed a |
122 | value rather than getting the value. |
123 | |
124 | =cut |
125 | |
126 | sub mk_group_wo_accessors { |
127 | my($self, $group, @fields) = @_; |
128 | |
129 | $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields); |
130 | } |
131 | |
132 | =head2 make_group_accessor |
133 | |
134 | =over 4 |
135 | |
136 | =item Arguments: $group, $field |
137 | |
138 | Returns: $sub (\CODE) |
139 | |
140 | =back |
141 | |
142 | Returns a single accessor in a given group; called by mk_group_accessors |
143 | for each entry in @fieldspec. |
144 | |
145 | =cut |
146 | |
147 | sub make_group_accessor { |
148 | my ($class, $group, $field) = @_; |
149 | |
150 | my $set = "set_$group"; |
151 | my $get = "get_$group"; |
152 | |
153 | # Build a closure around $field. |
154 | return sub { |
155 | my $self = shift; |
156 | |
157 | if(@_) { |
158 | return $self->$set($field, @_); |
159 | } |
160 | else { |
161 | return $self->$get($field); |
162 | } |
163 | }; |
164 | } |
165 | |
166 | =head2 make_group_ro_accessor |
167 | |
168 | =over 4 |
169 | |
170 | =item Arguments: $group, $field |
171 | |
172 | Returns: $sub (\CODE) |
173 | |
174 | =back |
175 | |
176 | Returns a single read-only accessor in a given group; called by |
177 | mk_group_ro_accessors for each entry in @fieldspec. |
178 | |
179 | =cut |
180 | |
181 | sub make_group_ro_accessor { |
182 | my($class, $group, $field) = @_; |
183 | |
184 | my $get = "get_$group"; |
185 | |
186 | return sub { |
187 | my $self = shift; |
188 | |
189 | if(@_) { |
190 | my $caller = caller; |
191 | croak("'$caller' cannot alter the value of '$field' on ". |
192 | "objects of class '$class'"); |
193 | } |
194 | else { |
195 | return $self->$get($field); |
196 | } |
197 | }; |
198 | } |
199 | |
200 | =head2 make_group_wo_accessor |
201 | |
202 | =over 4 |
203 | |
204 | =item Arguments: $group, $field |
205 | |
206 | Returns: $sub (\CODE) |
207 | |
208 | =back |
209 | |
210 | Returns a single write-only accessor in a given group; called by |
211 | mk_group_wo_accessors for each entry in @fieldspec. |
212 | |
213 | =cut |
214 | |
215 | sub make_group_wo_accessor { |
216 | my($class, $group, $field) = @_; |
217 | |
218 | my $set = "set_$group"; |
219 | |
220 | return sub { |
221 | my $self = shift; |
222 | |
223 | unless (@_) { |
224 | my $caller = caller; |
225 | croak("'$caller' cannot access the value of '$field' on ". |
226 | "objects of class '$class'"); |
227 | } |
228 | else { |
229 | return $self->$set($field, @_); |
230 | } |
231 | }; |
232 | } |
233 | |
234 | =head2 get_simple |
235 | |
236 | =over 4 |
237 | |
238 | =item Arguments: $field |
239 | |
240 | Returns: $value |
241 | |
242 | =back |
243 | |
244 | Simple getter for hash-based objects which returns the value for the field |
245 | name passed as an argument. |
246 | |
247 | =cut |
248 | |
249 | sub get_simple { |
250 | my ($self, $get) = @_; |
251 | return $self->{$get}; |
252 | } |
253 | |
254 | =head2 set_simple |
255 | |
256 | =over 4 |
257 | |
258 | =item Arguments: $field, $new_value |
259 | |
260 | Returns: $new_value |
261 | |
262 | =back |
263 | |
264 | Simple setter for hash-based objects which sets and then returns the value |
265 | for the field name passed as an argument. |
266 | |
267 | =cut |
268 | |
269 | sub set_simple { |
270 | my ($self, $set, $val) = @_; |
271 | return $self->{$set} = $val; |
272 | } |
273 | |
e6f2a0fd |
274 | |
275 | =head2 get_inherited |
276 | |
277 | =over 4 |
278 | |
279 | =item Arguments: $field |
280 | |
281 | Returns: $value |
282 | |
283 | =back |
284 | |
285 | Simple getter for Classes and hash-based objects which returns the value for the field name passed as |
286 | an argument. This behaves much like L<Class::Data::Accessor> where the field can be set in a |
287 | base class, inherited and changed in subclasses, and inherited and changed for object instances. |
288 | |
289 | =cut |
290 | |
291 | sub get_inherited { |
292 | my ($self, $get) = @_; |
293 | |
294 | if (blessed $self) { |
295 | if (reftype($self) eq 'HASH' && exists $self->{$get}) { |
296 | return $self->{$get}; |
297 | } elsif (reftype($self) ne 'HASH') { |
298 | croak('Cannot get inherited value on an object instance that is not hash-based'); |
299 | }; |
300 | }; |
301 | |
302 | no strict 'refs'; |
303 | |
304 | my @supers = Class::ISA::self_and_super_path(ref $self || $self); |
305 | foreach (@supers) { |
301f15cd |
306 | return ${$_.'::_'.$get} if defined(${$_.'::_'.$get}); |
e6f2a0fd |
307 | }; |
c46050d3 |
308 | |
309 | return; |
e6f2a0fd |
310 | } |
311 | |
312 | =head2 set_inherited |
313 | |
314 | =over 4 |
315 | |
316 | =item Arguments: $field, $new_value |
317 | |
318 | Returns: $new_value |
319 | |
320 | =back |
321 | |
322 | Simple setter for Classes and hash-based objects which sets and then returns the value |
323 | for the field name passed as an argument. When called on a hash-based object it will set the appropriate |
324 | hash key value. When called on a class, it will set a class level variable. |
325 | |
326 | B<Note:>: This method will die if you try to set an object variable on a non hash-based object. |
327 | |
328 | =cut |
329 | |
330 | sub set_inherited { |
331 | my ($self, $set, $val) = @_; |
332 | |
333 | if (blessed $self) { |
334 | if (reftype($self) eq 'HASH') { |
335 | return $self->{$set} = $val; |
336 | } else { |
337 | croak('Cannot set inherited value on an object instance that is not hash-based'); |
338 | }; |
339 | } else { |
340 | no strict 'refs'; |
341 | |
342 | return ${$self.'::_'.$set} = $val; |
343 | }; |
344 | } |
345 | |
963a69a5 |
346 | 1; |
347 | |
348 | =head1 AUTHORS |
349 | |
350 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
351 | |
352 | =head1 LICENSE |
353 | |
354 | You may distribute this code under the same terms as Perl itself. |
355 | |
356 | =cut |
357 | |