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