1 package DBIx::Class::AccessorGroup;
6 use Carp::Clan qw/^DBIx::Class/;
10 DBIx::Class::AccessorGroup - Lets you build groups of accessors
16 This class lets you build groups of accessors that will call different
21 =head2 mk_group_accessors
23 Creates a set of accessors in a given group.
25 =head3 Arguments: $group, @fieldspec
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.
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 ].
34 =head3 Return value: none
38 sub mk_group_accessors {
39 my ($self, $group, @fields) = @_;
41 $self->_mk_group_accessors('make_group_accessor', $group, @fields);
48 no warnings 'redefine';
50 sub _mk_group_accessors {
51 my($self, $maker, $group, @fields) = @_;
52 my $class = ref $self || $self;
54 # So we don't have to do lots of lookups inside the loop.
55 $maker = $self->can($maker) unless ref $maker;
57 foreach my $field (@fields) {
58 if( $field eq 'DESTROY' ) {
59 carp("Having a data accessor named DESTROY in ".
60 "'$class' is unwise.");
65 ($name, $field) = @$field if ref $field;
67 my $accessor = $self->$maker($group, $field);
68 my $alias = "_${name}_accessor";
70 #warn "$class $group $field $alias";
72 *{$class."\:\:$name"} = $accessor;
73 #unless defined &{$class."\:\:$field"}
75 *{$class."\:\:$alias"} = $accessor;
76 #unless defined &{$class."\:\:$alias"}
81 =head2 mk_group_ro_accessors
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.
87 =head3 Arguments: $group, @fieldspec
89 =head3 Return value: none
93 sub mk_group_ro_accessors {
94 my($self, $group, @fields) = @_;
96 $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
99 =head2 mk_group_wo_accessors
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.
105 =head3 Arguments: $group, @fieldspec
107 =head3 Return value: none
111 sub mk_group_wo_accessors {
112 my($self, $group, @fields) = @_;
114 $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
117 =head2 make_group_accessor
119 Returns a single accessor in a given group; called by mk_group_accessors
120 for each entry in @fieldspec.
122 =head3 Arguments: $group, $field
124 =head3 Return value: $sub (\CODE)
128 sub make_group_accessor {
129 my ($class, $group, $field) = @_;
131 my $set = "set_$group";
132 my $get = "get_$group";
134 # Build a closure around $field.
139 return $self->$set($field, @_);
142 return $self->$get($field);
147 =head2 make_group_ro_accessor
149 Returns a single read-only accessor in a given group; called by
150 mk_group_ro_accessors for each entry in @fieldspec.
152 =head3 Arguments: $group, $field
154 =head3 Return value: $sub (\CODE)
158 sub make_group_ro_accessor {
159 my($class, $group, $field) = @_;
161 my $get = "get_$group";
168 croak("'$caller' cannot alter the value of '$field' on ".
169 "objects of class '$class'");
172 return $self->$get($field);
177 =head2 make_group_wo_accessor
179 Returns a single write-only accessor in a given group; called by
180 mk_group_wo_accessors for each entry in @fieldspec.
182 =head3 Arguments: $group, $field
184 =head3 Return value: $sub (\CODE)
188 sub make_group_wo_accessor {
189 my($class, $group, $field) = @_;
191 my $set = "set_$group";
198 croak("'$caller' cannot access the value of '$field' on ".
199 "objects of class '$class'");
202 return $self->$set($field, @_);
209 Simple getter for hash-based objects which returns the value for the field
210 name passed as an argument.
212 =head3 Arguments: $field
214 =head3 Return value: $value
219 my ($self, $get) = @_;
220 return $self->{$get};
225 Simple setter for hash-based objects which sets and then returns the value
226 for the field name passed as an argument.
228 =head3 Arguments: $field, $new_value
230 =head3 Return value: $new_value
235 my ($self, $set, $val) = @_;
236 return $self->{$set} = $val;
239 =head2 get_component_class
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
245 =head3 Arguments: $name
247 =head3 Return value: $component_class
251 sub get_component_class {
252 my ($self, $get) = @_;
254 return $self->{$get};
257 return $self->can($get) ? $self->$get : undef;
261 =head2 set_component_class
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.
267 =head3 Arguments: $name, $new_component_class
269 =head3 Return value: $new_component_class
273 sub set_component_class {
274 my ($self, $set, $val) = @_;
277 return $self->{$set} = $val;
280 return $self->can($set) ? $self->$set($val) : $self->mk_classdata($set => $val);
288 Matt S. Trout <mst@shadowcatsystems.co.uk>
292 You may distribute this code under the same terms as Perl itself.