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