Merge 'trunk' into 'DBIx-Class-C3'
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / AccessorGroup.pm
CommitLineData
fe5d862b 1package DBIx::Class::AccessorGroup;
2
12bbb339 3use strict;
4use warnings;
5
604d9f38 6use NEXT;
12bbb339 7
34d52be2 8=head1 NAME
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
21=over 4
22
23=cut
24
fe5d862b 25sub mk_group_accessors {
26 my($self, $group, @fields) = @_;
27
28 $self->_mk_group_accessors('make_group_accessor', $group, @fields);
29}
30
31
32{
33 no strict 'refs';
12bbb339 34 no warnings 'redefine';
fe5d862b 35
36 sub _mk_group_accessors {
37 my($self, $maker, $group, @fields) = @_;
38 my $class = ref $self || $self;
39
40 # So we don't have to do lots of lookups inside the loop.
41 $maker = $self->can($maker) unless ref $maker;
42
43 foreach my $field (@fields) {
44 if( $field eq 'DESTROY' ) {
45 require Carp;
46 &Carp::carp("Having a data accessor named DESTROY in ".
47 "'$class' is unwise.");
48 }
49
b8e1e21f 50 my $name = $field;
51
52 ($name, $field) = @$field if ref $field;
53
fe5d862b 54 my $accessor = $self->$maker($group, $field);
b8e1e21f 55 my $alias = "_${name}_accessor";
fe5d862b 56
12bbb339 57 #warn "$class $group $field $alias";
fe5d862b 58
b8e1e21f 59 *{$class."\:\:$name"} = $accessor;
12bbb339 60 #unless defined &{$class."\:\:$field"}
61
62 *{$class."\:\:$alias"} = $accessor;
63 #unless defined &{$class."\:\:$alias"}
fe5d862b 64 }
65 }
66}
67
68sub mk_group_ro_accessors {
69 my($self, $group, @fields) = @_;
70
71 $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
72}
73
74sub mk_group_wo_accessors {
75 my($self, $group, @fields) = @_;
76
77 $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
78}
79
80sub make_group_accessor {
81 my ($class, $group, $field) = @_;
82
83 my $set = "set_$group";
84 my $get = "get_$group";
85
86 # Build a closure around $field.
87 return sub {
88 my $self = shift;
89
90 if(@_) {
12bbb339 91 return $self->$set($field, @_);
fe5d862b 92 }
93 else {
12bbb339 94 return $self->$get($field);
fe5d862b 95 }
96 };
97}
98
99sub make_group_ro_accessor {
100 my($class, $group, $field) = @_;
101
102 my $get = "get_$group";
103
104 return sub {
105 my $self = shift;
106
107 if(@_) {
108 my $caller = caller;
109 require Carp;
110 Carp::croak("'$caller' cannot alter the value of '$field' on ".
111 "objects of class '$class'");
112 }
113 else {
12bbb339 114 return $self->$get($field);
fe5d862b 115 }
116 };
117}
118
119sub make_group_wo_accessor {
120 my($class, $group, $field) = @_;
121
122 my $set = "set_$group";
123
124 return sub {
125 my $self = shift;
126
127 unless (@_) {
128 my $caller = caller;
129 require Carp;
130 Carp::croak("'$caller' cannot access the value of '$field' on ".
131 "objects of class '$class'");
132 }
133 else {
12bbb339 134 return $self->$set($field, @_);
fe5d862b 135 }
136 };
137}
138
484c9dda 139sub get_simple {
140 my ($self, $get) = @_;
141 return $self->{$get};
142}
143
144sub set_simple {
145 my ($self, $set, $val) = @_;
146 return $self->{$set} = $val;
147}
148
fe5d862b 1491;
34d52be2 150
151=back
152
153=head1 AUTHORS
154
daec44b8 155Matt S. Trout <mst@shadowcatsystems.co.uk>
34d52be2 156
157=head1 LICENSE
158
159You may distribute this code under the same terms as Perl itself.
160
161=cut
162