Commit | Line | Data |
963a69a5 |
1 | package Class::Accessor::Grouped; |
2 | use strict; |
3 | use warnings; |
0fea2bfb |
4 | use Carp; |
331e820d |
5 | use Class::Inspector (); |
874177a3 |
6 | use Scalar::Util qw/reftype blessed/; |
8787799c |
7 | use MRO::Compat; |
331e820d |
8 | |
963a69a5 |
9 | use vars qw($VERSION); |
10 | |
8787799c |
11 | $VERSION = '0.06000'; |
963a69a5 |
12 | |
13 | =head1 NAME |
14 | |
1ad8d8c6 |
15 | Class::Accessor::Grouped - Lets you build groups of accessors |
963a69a5 |
16 | |
17 | =head1 SYNOPSIS |
18 | |
19 | =head1 DESCRIPTION |
20 | |
21 | This class lets you build groups of accessors that will call different |
22 | getters and setters. |
23 | |
24 | =head1 METHODS |
25 | |
26 | =head2 mk_group_accessors |
27 | |
28 | =over 4 |
29 | |
30 | =item Arguments: $group, @fieldspec |
31 | |
32 | Returns: none |
33 | |
34 | =back |
35 | |
36 | Creates a set of accessors in a given group. |
37 | |
38 | $group is the name of the accessor group for the generated accessors; they |
39 | will call get_$group($field) on get and set_$group($field, $value) on set. |
40 | |
41 | @fieldspec is a list of field/accessor names; if a fieldspec is a scalar |
42 | this is used as both field and accessor name, if a listref it is expected to |
43 | be of the form [ $accessor, $field ]. |
44 | |
45 | =cut |
46 | |
47 | sub mk_group_accessors { |
48 | my ($self, $group, @fields) = @_; |
49 | |
50 | $self->_mk_group_accessors('make_group_accessor', $group, @fields); |
51 | return; |
52 | } |
53 | |
54 | |
55 | { |
56 | no strict 'refs'; |
57 | no warnings 'redefine'; |
58 | |
59 | sub _mk_group_accessors { |
60 | my($self, $maker, $group, @fields) = @_; |
874177a3 |
61 | my $class = blessed $self || $self; |
963a69a5 |
62 | |
63 | # So we don't have to do lots of lookups inside the loop. |
64 | $maker = $self->can($maker) unless ref $maker; |
65 | |
66 | foreach my $field (@fields) { |
67 | if( $field eq 'DESTROY' ) { |
68 | carp("Having a data accessor named DESTROY in ". |
69 | "'$class' is unwise."); |
70 | } |
71 | |
72 | my $name = $field; |
73 | |
74 | ($name, $field) = @$field if ref $field; |
75 | |
76 | my $accessor = $self->$maker($group, $field); |
77 | my $alias = "_${name}_accessor"; |
78 | |
963a69a5 |
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 | |
331e820d |
285 | Simple getter for Classes and hash-based objects which returns the value for |
286 | the field name passed as an argument. This behaves much like |
287 | L<Class::Data::Accessor> where the field can be set in a base class, |
288 | inherited and changed in subclasses, and inherited and changed for object |
289 | instances. |
e6f2a0fd |
290 | |
291 | =cut |
292 | |
293 | sub get_inherited { |
294 | my ($self, $get) = @_; |
a49c32d9 |
295 | my $class; |
e6f2a0fd |
296 | |
874177a3 |
297 | if (blessed $self) { |
298 | my $reftype = reftype $self; |
a49c32d9 |
299 | $class = ref $self; |
300 | |
301 | if ($reftype eq 'HASH' && exists $self->{$get}) { |
e6f2a0fd |
302 | return $self->{$get}; |
a49c32d9 |
303 | } elsif ($reftype ne 'HASH') { |
e6f2a0fd |
304 | croak('Cannot get inherited value on an object instance that is not hash-based'); |
305 | }; |
a49c32d9 |
306 | } else { |
307 | $class = $self; |
e6f2a0fd |
308 | }; |
309 | |
310 | no strict 'refs'; |
a49c32d9 |
311 | return ${$class.'::__cag_'.$get} if defined(${$class.'::__cag_'.$get}); |
e6f2a0fd |
312 | |
a49c32d9 |
313 | if (!@{$class.'::__cag_supers'}) { |
314 | @{$class.'::__cag_supers'} = $self->get_super_paths; |
315 | }; |
316 | |
317 | foreach (@{$class.'::__cag_supers'}) { |
318 | return ${$_.'::__cag_'.$get} if defined(${$_.'::__cag_'.$get}); |
e6f2a0fd |
319 | }; |
c46050d3 |
320 | |
321 | return; |
e6f2a0fd |
322 | } |
323 | |
324 | =head2 set_inherited |
325 | |
326 | =over 4 |
327 | |
328 | =item Arguments: $field, $new_value |
329 | |
330 | Returns: $new_value |
331 | |
332 | =back |
333 | |
331e820d |
334 | Simple setter for Classes and hash-based objects which sets and then returns |
335 | the value for the field name passed as an argument. When called on a hash-based |
336 | object it will set the appropriate hash key value. When called on a class, it |
337 | will set a class level variable. |
e6f2a0fd |
338 | |
331e820d |
339 | B<Note:>: This method will die if you try to set an object variable on a non |
340 | hash-based object. |
e6f2a0fd |
341 | |
342 | =cut |
343 | |
344 | sub set_inherited { |
345 | my ($self, $set, $val) = @_; |
346 | |
874177a3 |
347 | if (blessed $self) { |
348 | if (reftype $self eq 'HASH') { |
e6f2a0fd |
349 | return $self->{$set} = $val; |
350 | } else { |
351 | croak('Cannot set inherited value on an object instance that is not hash-based'); |
352 | }; |
353 | } else { |
354 | no strict 'refs'; |
355 | |
a49c32d9 |
356 | return ${$self.'::__cag_'.$set} = $val; |
e6f2a0fd |
357 | }; |
358 | } |
359 | |
331e820d |
360 | =head2 get_component_class |
361 | |
362 | =over 4 |
363 | |
364 | =item Arguments: $field |
365 | |
366 | Returns: $value |
367 | |
368 | =back |
369 | |
370 | Gets the value of the specified component class. |
371 | |
372 | __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); |
373 | |
374 | $self->result_class->method(); |
375 | |
376 | ## same as |
377 | $self->get_component_class('result_class')->method(); |
378 | |
379 | =cut |
380 | |
381 | sub get_component_class { |
382 | my ($self, $field) = @_; |
383 | |
384 | return $self->get_inherited($field); |
385 | }; |
386 | |
387 | =head2 set_component_class |
388 | |
389 | =over 4 |
390 | |
391 | =item Arguments: $field, $class |
392 | |
393 | Returns: $new_value |
394 | |
395 | =back |
396 | |
397 | Inherited accessor that automatically loads the specified class before setting |
398 | it. This method will die if the specified class could not be loaded. |
399 | |
400 | __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); |
401 | __PACKAGE__->result_class('MyClass'); |
402 | |
403 | $self->result_class->method(); |
404 | |
405 | =cut |
406 | |
407 | sub set_component_class { |
408 | my ($self, $field, $value) = @_; |
409 | |
410 | if ($value) { |
bce7bdf8 |
411 | local $^W = 0; |
874177a3 |
412 | if (Class::Inspector->installed($value) && !Class::Inspector->loaded($value)) { |
331e820d |
413 | eval "use $value"; |
414 | |
415 | croak("Could not load $field '$value': ", $@) if $@; |
416 | }; |
417 | }; |
418 | |
419 | return $self->set_inherited($field, $value); |
420 | }; |
421 | |
a49c32d9 |
422 | =head2 get_super_paths |
423 | |
424 | Returns a list of 'parent' or 'super' class names that the current class inherited from. |
425 | |
426 | =cut |
427 | |
428 | sub get_super_paths { |
874177a3 |
429 | my $class = blessed $_[0] || $_[0]; |
a49c32d9 |
430 | |
8787799c |
431 | return @{mro::get_linear_isa($class)}; |
a49c32d9 |
432 | }; |
433 | |
963a69a5 |
434 | 1; |
435 | |
436 | =head1 AUTHORS |
437 | |
438 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
97972dcb |
439 | Christopher H. Laco <claco@chrislaco.com> |
963a69a5 |
440 | |
441 | =head1 LICENSE |
442 | |
443 | You may distribute this code under the same terms as Perl itself. |
444 | |
445 | =cut |
446 | |