Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Method::Accessor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed', 'weaken'; |
9 | use Try::Tiny; |
10 | |
38bf2a25 |
11 | use base 'Class::MOP::Method::Generated'; |
12 | |
13 | sub new { |
14 | my $class = shift; |
15 | my %options = @_; |
16 | |
17 | (exists $options{attribute}) |
18 | || confess "You must supply an attribute to construct with"; |
19 | |
20 | (exists $options{accessor_type}) |
21 | || confess "You must supply an accessor_type to construct with"; |
22 | |
23 | (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) |
24 | || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; |
25 | |
26 | ($options{package_name} && $options{name}) |
27 | || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; |
28 | |
29 | my $self = $class->_new(\%options); |
30 | |
31 | # we don't want this creating |
32 | # a cycle in the code, if not |
33 | # needed |
34 | weaken($self->{'attribute'}); |
35 | |
36 | $self->_initialize_body; |
37 | |
38 | return $self; |
39 | } |
40 | |
41 | sub _new { |
42 | my $class = shift; |
43 | |
44 | return Class::MOP::Class->initialize($class)->new_object(@_) |
45 | if $class ne __PACKAGE__; |
46 | |
47 | my $params = @_ == 1 ? $_[0] : {@_}; |
48 | |
49 | return bless { |
50 | # inherited from Class::MOP::Method |
51 | body => $params->{body}, |
52 | associated_metaclass => $params->{associated_metaclass}, |
53 | package_name => $params->{package_name}, |
54 | name => $params->{name}, |
55 | original_method => $params->{original_method}, |
56 | |
57 | # inherit from Class::MOP::Generated |
58 | is_inline => $params->{is_inline} || 0, |
59 | definition_context => $params->{definition_context}, |
60 | |
61 | # defined in this class |
62 | attribute => $params->{attribute}, |
63 | accessor_type => $params->{accessor_type}, |
64 | } => $class; |
65 | } |
66 | |
67 | ## accessors |
68 | |
69 | sub associated_attribute { (shift)->{'attribute'} } |
70 | sub accessor_type { (shift)->{'accessor_type'} } |
71 | |
72 | ## factory |
73 | |
74 | sub _initialize_body { |
75 | my $self = shift; |
76 | |
77 | my $method_name = join "_" => ( |
78 | '_generate', |
79 | $self->accessor_type, |
8b0f4faf |
80 | 'method' |
38bf2a25 |
81 | ); |
82 | |
83 | $self->{'body'} = $self->$method_name(); |
84 | } |
85 | |
8b0f4faf |
86 | sub _error_thrower { |
87 | my $self = shift; |
88 | |
89 | return $self->associated_attribute |
90 | if ref $self |
91 | && $self->associated_attribute |
92 | && $self->associated_attribute->can('throw_error'); |
93 | |
94 | return $self->SUPER::_error_thrower; |
95 | } |
96 | |
97 | sub _compile_code { |
98 | my $self = shift; |
99 | my @args = @_; |
100 | try { |
101 | $self->SUPER::_compile_code(@args); |
102 | } |
103 | catch { |
104 | $self->throw_error( |
105 | 'Could not create writer for ' |
106 | . "'" . $self->associated_attribute->name . "' " |
107 | . 'because ' . $_, |
108 | error => $_, |
109 | ); |
110 | }; |
111 | } |
112 | |
113 | sub _eval_environment { |
114 | my $self = shift; |
115 | return $self->associated_attribute->_eval_environment |
116 | if $self->associated_attribute->can('_eval_environment'); |
117 | } |
118 | |
119 | sub _instance_is_inlinable { |
120 | my $self = shift; |
121 | return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable; |
122 | } |
123 | |
124 | sub _generate_reader_method { |
125 | my $self = shift; |
126 | $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_) |
127 | : $self->_generate_reader_method_non_inline(@_); |
128 | } |
129 | |
130 | sub _generate_writer_method { |
131 | my $self = shift; |
132 | $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_) |
133 | : $self->_generate_writer_method_non_inline(@_); |
134 | } |
38bf2a25 |
135 | |
136 | sub _generate_accessor_method { |
137 | my $self = shift; |
8b0f4faf |
138 | $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_) |
139 | : $self->_generate_accessor_method_non_inline(@_); |
140 | } |
141 | |
142 | sub _generate_predicate_method { |
143 | my $self = shift; |
144 | $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_) |
145 | : $self->_generate_predicate_method_non_inline(@_); |
146 | } |
147 | |
148 | sub _generate_clearer_method { |
149 | my $self = shift; |
150 | $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_) |
151 | : $self->_generate_clearer_method_non_inline(@_); |
152 | } |
153 | |
154 | sub _generate_accessor_method_non_inline { |
155 | my $self = shift; |
38bf2a25 |
156 | my $attr = $self->associated_attribute; |
157 | |
158 | return sub { |
159 | if (@_ >= 2) { |
160 | $attr->set_value($_[0], $_[1]); |
161 | } |
162 | $attr->get_value($_[0]); |
163 | }; |
164 | } |
165 | |
166 | sub _generate_accessor_method_inline { |
167 | my $self = shift; |
168 | my $attr = $self->associated_attribute; |
169 | |
170 | return try { |
171 | $self->_compile_code([ |
172 | 'sub {', |
173 | 'if (@_ > 1) {', |
174 | $attr->_inline_set_value('$_[0]', '$_[1]'), |
175 | '}', |
176 | $attr->_inline_get_value('$_[0]'), |
177 | '}', |
178 | ]); |
179 | } |
180 | catch { |
181 | confess "Could not generate inline accessor because : $_"; |
182 | }; |
183 | } |
184 | |
8b0f4faf |
185 | sub _generate_reader_method_non_inline { |
38bf2a25 |
186 | my $self = shift; |
187 | my $attr = $self->associated_attribute; |
188 | |
189 | return sub { |
190 | confess "Cannot assign a value to a read-only accessor" |
191 | if @_ > 1; |
192 | $attr->get_value($_[0]); |
193 | }; |
194 | } |
195 | |
196 | sub _generate_reader_method_inline { |
197 | my $self = shift; |
198 | my $attr = $self->associated_attribute; |
199 | |
200 | return try { |
201 | $self->_compile_code([ |
202 | 'sub {', |
203 | 'if (@_ > 1) {', |
204 | # XXX: this is a hack, but our error stuff is terrible |
205 | $self->_inline_throw_error( |
206 | '"Cannot assign a value to a read-only accessor"', |
207 | 'data => \@_' |
208 | ) . ';', |
209 | '}', |
210 | $attr->_inline_get_value('$_[0]'), |
211 | '}', |
212 | ]); |
213 | } |
214 | catch { |
215 | confess "Could not generate inline reader because : $_"; |
216 | }; |
217 | } |
218 | |
8b0f4faf |
219 | sub _generate_writer_method_non_inline { |
38bf2a25 |
220 | my $self = shift; |
221 | my $attr = $self->associated_attribute; |
222 | |
223 | return sub { |
224 | $attr->set_value($_[0], $_[1]); |
225 | }; |
226 | } |
227 | |
228 | sub _generate_writer_method_inline { |
229 | my $self = shift; |
230 | my $attr = $self->associated_attribute; |
231 | |
232 | return try { |
233 | $self->_compile_code([ |
234 | 'sub {', |
235 | $attr->_inline_set_value('$_[0]', '$_[1]'), |
236 | '}', |
237 | ]); |
238 | } |
239 | catch { |
240 | confess "Could not generate inline writer because : $_"; |
241 | }; |
242 | } |
243 | |
8b0f4faf |
244 | sub _generate_predicate_method_non_inline { |
38bf2a25 |
245 | my $self = shift; |
246 | my $attr = $self->associated_attribute; |
247 | |
248 | return sub { |
249 | $attr->has_value($_[0]) |
250 | }; |
251 | } |
252 | |
253 | sub _generate_predicate_method_inline { |
254 | my $self = shift; |
255 | my $attr = $self->associated_attribute; |
256 | |
257 | return try { |
258 | $self->_compile_code([ |
259 | 'sub {', |
260 | $attr->_inline_has_value('$_[0]'), |
261 | '}', |
262 | ]); |
263 | } |
264 | catch { |
265 | confess "Could not generate inline predicate because : $_"; |
266 | }; |
267 | } |
268 | |
8b0f4faf |
269 | sub _generate_clearer_method_non_inline { |
38bf2a25 |
270 | my $self = shift; |
271 | my $attr = $self->associated_attribute; |
272 | |
273 | return sub { |
274 | $attr->clear_value($_[0]) |
275 | }; |
276 | } |
277 | |
278 | sub _generate_clearer_method_inline { |
279 | my $self = shift; |
280 | my $attr = $self->associated_attribute; |
281 | |
282 | return try { |
283 | $self->_compile_code([ |
284 | 'sub {', |
285 | $attr->_inline_clear_value('$_[0]'), |
286 | '}', |
287 | ]); |
288 | } |
289 | catch { |
290 | confess "Could not generate inline clearer because : $_"; |
291 | }; |
292 | } |
293 | |
8b0f4faf |
294 | sub _writer_value_needs_copy { |
295 | shift->associated_attribute->_writer_value_needs_copy(@_); |
296 | } |
297 | |
298 | sub _inline_tc_code { |
299 | shift->associated_attribute->_inline_tc_code(@_); |
300 | } |
301 | |
302 | sub _inline_check_coercion { |
303 | shift->associated_attribute->_inline_check_coercion(@_); |
304 | } |
305 | |
306 | sub _inline_check_constraint { |
307 | shift->associated_attribute->_inline_check_constraint(@_); |
308 | } |
309 | |
310 | sub _inline_check_lazy { |
311 | shift->associated_attribute->_inline_check_lazy(@_); |
312 | } |
313 | |
314 | sub _inline_store_value { |
315 | shift->associated_attribute->_inline_instance_set(@_) . ';'; |
316 | } |
317 | |
318 | sub _inline_get_old_value_for_trigger { |
319 | shift->associated_attribute->_inline_get_old_value_for_trigger(@_); |
320 | } |
321 | |
322 | sub _inline_trigger { |
323 | shift->associated_attribute->_inline_trigger(@_); |
324 | } |
325 | |
326 | sub _get_value { |
327 | shift->associated_attribute->_inline_instance_get(@_); |
328 | } |
329 | |
330 | sub _has_value { |
331 | shift->associated_attribute->_inline_instance_has(@_); |
332 | } |
333 | |
38bf2a25 |
334 | 1; |
335 | |
336 | # ABSTRACT: Method Meta Object for accessors |
337 | |
338 | __END__ |
339 | |
340 | =pod |
341 | |
342 | =head1 SYNOPSIS |
343 | |
344 | use Class::MOP::Method::Accessor; |
345 | |
346 | my $reader = Class::MOP::Method::Accessor->new( |
347 | attribute => $attribute, |
348 | is_inline => 1, |
349 | accessor_type => 'reader', |
350 | ); |
351 | |
352 | $reader->body->execute($instance); # call the reader method |
353 | |
354 | =head1 DESCRIPTION |
355 | |
356 | This is a subclass of C<Class::MOP::Method> which is used by |
357 | C<Class::MOP::Attribute> to generate accessor code. It handles |
358 | generation of readers, writers, predicates and clearers. For each type |
359 | of method, it can either create a subroutine reference, or actually |
360 | inline code by generating a string and C<eval>'ing it. |
361 | |
362 | =head1 METHODS |
363 | |
364 | =over 4 |
365 | |
366 | =item B<< Class::MOP::Method::Accessor->new(%options) >> |
367 | |
368 | This returns a new C<Class::MOP::Method::Accessor> based on the |
369 | C<%options> provided. |
370 | |
371 | =over 4 |
372 | |
373 | =item * attribute |
374 | |
375 | This is the C<Class::MOP::Attribute> for which accessors are being |
376 | generated. This option is required. |
377 | |
378 | =item * accessor_type |
379 | |
380 | This is a string which should be one of "reader", "writer", |
381 | "accessor", "predicate", or "clearer". This is the type of method |
382 | being generated. This option is required. |
383 | |
384 | =item * is_inline |
385 | |
386 | This indicates whether or not the accessor should be inlined. This |
387 | defaults to false. |
388 | |
389 | =item * name |
390 | |
391 | The method name (without a package name). This is required. |
392 | |
393 | =item * package_name |
394 | |
395 | The package name for the method. This is required. |
396 | |
397 | =back |
398 | |
399 | =item B<< $metamethod->accessor_type >> |
400 | |
401 | Returns the accessor type which was passed to C<new>. |
402 | |
403 | =item B<< $metamethod->is_inline >> |
404 | |
405 | Returns a boolean indicating whether or not the accessor is inlined. |
406 | |
407 | =item B<< $metamethod->associated_attribute >> |
408 | |
409 | This returns the L<Class::MOP::Attribute> object which was passed to |
410 | C<new>. |
411 | |
412 | =item B<< $metamethod->body >> |
413 | |
414 | The method itself is I<generated> when the accessor object is |
415 | constructed. |
416 | |
417 | =back |
418 | |
419 | =cut |
420 | |