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