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