error message for failed delegation should use the attribute name, not the delegate...
[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor.pm
1
2 package Moose::Meta::Method::Accessor;
3
4 use strict;
5 use warnings;
6
7 our $VERSION   = '0.68';
8 $VERSION = eval $VERSION;
9 our $AUTHORITY = 'cpan:STEVAN';
10
11 use base 'Moose::Meta::Method',
12          'Class::MOP::Method::Accessor';
13
14 sub _error_thrower {
15     my $self = shift;
16     ( ref $self && $self->associated_attribute ) || $self->SUPER::_error_thrower();
17 }
18
19 sub _eval_code {
20     my ( $self, $code ) = @_;
21
22     # NOTE:
23     # set up the environment
24     my $attr = $self->associated_attribute;
25     my $type_constraint_obj = $attr->type_constraint;
26     my $environment = {
27         '$attr' => \$attr,
28         '$attr_name' => \$attr->name,
29         '$meta' => \$self,
30         '$type_constraint_obj' => \$type_constraint_obj,
31         '$type_constraint_name' => \($type_constraint_obj && $type_constraint_obj->name),
32         '$type_constraint' => \($type_constraint_obj
33                                    ? $type_constraint_obj->_compiled_type_constraint
34                                    : undef),
35     };
36
37     #warn "code for $attr_name =>\n" . $code . "\n";
38     $self->_compile_code( environment => $environment, code => $code )
39         or $self->throw_error("Could not create writer for '${\$self->associated_attribute->name}' because $@ \n code: $code", error => $@, data => $code );
40 }
41
42 sub generate_accessor_method_inline {
43     my $self        = $_[0];
44     my $attr        = $self->associated_attribute;
45     my $attr_name   = $attr->name;
46     my $inv         = '$_[0]';
47     my $slot_access = $self->_inline_access($inv, $attr_name);
48     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
49
50     $self->_eval_code('sub { ' . "\n"
51     . $self->_inline_pre_body(@_) . "\n"
52     . 'if (scalar(@_) >= 2) {' . "\n"
53         . $self->_inline_copy_value . "\n"
54         . $self->_inline_check_required . "\n"
55         . $self->_inline_check_coercion . "\n"
56         . $self->_inline_check_constraint($value_name) . "\n"
57         . $self->_inline_store($inv, $value_name) . "\n"
58         . $self->_inline_trigger($inv, $value_name) . "\n"
59     . ' }' . "\n"
60     . $self->_inline_check_lazy($inv) . "\n"
61     . $self->_inline_post_body(@_) . "\n"
62     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
63     . ' }');
64 }
65
66 sub generate_writer_method_inline {
67     my $self        = $_[0];
68     my $attr        = $self->associated_attribute;
69     my $attr_name   = $attr->name;
70     my $inv         = '$_[0]';
71     my $slot_access = $self->_inline_get($inv, $attr_name);
72     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
73
74     $self->_eval_code('sub { '
75     . $self->_inline_pre_body(@_)
76     . $self->_inline_copy_value
77     . $self->_inline_check_required
78     . $self->_inline_check_coercion
79     . $self->_inline_check_constraint($value_name)
80     . $self->_inline_store($inv, $value_name)
81     . $self->_inline_post_body(@_)
82     . $self->_inline_trigger($inv, $value_name)
83     . ' }');
84 }
85
86 sub generate_reader_method_inline {
87     my $self        = $_[0];
88     my $attr        = $self->associated_attribute;
89     my $attr_name   = $attr->name;
90     my $inv         = '$_[0]';
91     my $slot_access = $self->_inline_get($inv, $attr_name);
92
93     $self->_eval_code('sub {'
94     . $self->_inline_pre_body(@_)
95     . $self->_inline_throw_error('"Cannot assign a value to a read-only accessor"', 'data => \@_') . ' if @_ > 1;'
96     . $self->_inline_check_lazy($inv)
97     . $self->_inline_post_body(@_)
98     . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
99     . '}');
100 }
101
102 sub _inline_copy_value {
103     return '' unless shift->_value_needs_copy;
104     return 'my $val = $_[1];'
105 }
106
107 sub _value_needs_copy {
108     my $attr = (shift)->associated_attribute;
109     return $attr->should_coerce;
110 }
111
112 sub generate_reader_method { shift->generate_reader_method_inline(@_) }
113 sub generate_writer_method { shift->generate_writer_method_inline(@_) }
114 sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }
115 sub generate_predicate_method { shift->generate_predicate_method_inline(@_) }
116 sub generate_clearer_method { shift->generate_clearer_method_inline(@_) }
117
118 sub _inline_pre_body  { '' }
119 sub _inline_post_body { '' }
120
121 sub _inline_check_constraint {
122     my ($self, $value) = @_;
123     
124     my $attr = $self->associated_attribute;
125     my $attr_name = $attr->name;
126     
127     return '' unless $attr->has_type_constraint;
128     
129     my $type_constraint_name = $attr->type_constraint->name;
130
131     qq{\$type_constraint->($value) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) does not pass the type constraint because: " . \$type_constraint_obj->get_message($value)}, "data => $value") . ";";
132 }
133
134 sub _inline_check_coercion {
135     my $attr = (shift)->associated_attribute;
136     
137     return '' unless $attr->should_coerce;
138     return '$val = $attr->type_constraint->coerce($_[1]);'
139 }
140
141 sub _inline_check_required {
142     my $self = shift;
143     my $attr = $self->associated_attribute;
144
145     my $attr_name = $attr->name;
146     
147     return '' unless $attr->is_required;
148     return qq{(\@_ >= 2) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) is required, so cannot be set to undef"}) . ';' # defined $_[1] is not good enough
149 }
150
151 sub _inline_check_lazy {
152     my ($self, $instance) = @_;
153
154     my $attr = $self->associated_attribute;
155
156     return '' unless $attr->is_lazy;
157
158     my $slot_access = $self->_inline_access($instance, $attr->name);
159
160     my $slot_exists = $self->_inline_has($instance, $attr->name);
161
162     my $code = 'unless (' . $slot_exists . ') {' . "\n";
163     if ($attr->has_type_constraint) {
164         if ($attr->has_default || $attr->has_builder) {
165             if ($attr->has_default) {
166                 $code .= '    my $default = $attr->default(' . $instance . ');'."\n";
167             } 
168             elsif ($attr->has_builder) {
169                 $code .= '    my $default;'."\n".
170                          '    if(my $builder = '.$instance.'->can($attr->builder)){ '."\n".
171                          '        $default = '.$instance.'->$builder; '. "\n    } else {\n" .
172                          '        ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name') .
173                          ';'. "\n    }";
174             }
175             $code .= '    $default = $type_constraint_obj->coerce($default);'."\n"  if $attr->should_coerce;
176             $code .= '    ($type_constraint->($default))' .
177                      '            || ' . $self->_inline_throw_error('"Attribute (" . $attr_name . ") does not pass the type constraint ("' .
178                      '           . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef")' ) . ';' 
179                      . "\n";
180             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, '$default') . "\n";
181         } 
182         else {
183             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
184         }
185
186     } else {
187         if ($attr->has_default) {
188             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, ('$attr->default(' . $instance . ')')) . "\n";            
189         } 
190         elsif ($attr->has_builder) {
191             $code .= '    if (my $builder = '.$instance.'->can($attr->builder)) { ' . "\n" 
192                   .  '       ' . $self->_inline_init_slot($attr, $instance, $slot_access, ($instance . '->$builder'))           
193                   .  "\n    } else {\n"
194                   .  '        ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name')
195                   .  ';'. "\n    }";
196         } 
197         else {
198             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
199         }
200     }
201     $code .= "}\n";
202     return $code;
203 }
204
205 sub _inline_init_slot {
206     my ($self, $attr, $inv, $slot_access, $value) = @_;
207     if ($attr->has_initializer) {
208         return ('$attr->set_initial_value(' . $inv . ', ' . $value . ');');
209     }
210     else {
211         return ($slot_access . ' = ' . $value . ';');
212     }    
213 }
214
215 sub _inline_store {
216     my ($self, $instance, $value) = @_;
217     my $attr = $self->associated_attribute;
218     
219     my $mi = $attr->associated_class->get_meta_instance;
220     my $slot_name = sprintf "'%s'", $attr->slots;
221     
222     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
223     $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
224         if $attr->is_weak_ref;
225     return $code;
226 }
227
228 sub _inline_trigger {
229     my ($self, $instance, $value) = @_;
230     my $attr = $self->associated_attribute;
231     return '' unless $attr->has_trigger;
232     return sprintf('$attr->trigger->(%s, %s);', $instance, $value);
233 }
234
235 sub _inline_get {
236     my ($self, $instance) = @_;
237     my $attr = $self->associated_attribute;
238     
239     my $mi = $attr->associated_class->get_meta_instance;
240     my $slot_name = sprintf "'%s'", $attr->slots;
241
242     return $mi->inline_get_slot_value($instance, $slot_name);
243 }
244
245 sub _inline_access {
246     my ($self, $instance) = @_;
247     my $attr = $self->associated_attribute;
248     
249     my $mi = $attr->associated_class->get_meta_instance;
250     my $slot_name = sprintf "'%s'", $attr->slots;
251
252     return $mi->inline_slot_access($instance, $slot_name);
253 }
254
255 sub _inline_has {
256     my ($self, $instance) = @_;
257     my $attr = $self->associated_attribute;
258     
259     my $mi = $attr->associated_class->get_meta_instance;
260     my $slot_name = sprintf "'%s'", $attr->slots;
261
262     return $mi->inline_is_slot_initialized($instance, $slot_name);
263 }
264
265 sub _inline_auto_deref {
266     my ( $self, $ref_value ) = @_;
267         my $attr = $self->associated_attribute;
268
269     return $ref_value unless $attr->should_auto_deref;
270
271     my $type_constraint = $attr->type_constraint;
272
273     my $sigil;
274     if ($type_constraint->is_a_type_of('ArrayRef')) {
275         $sigil = '@';
276     }
277     elsif ($type_constraint->is_a_type_of('HashRef')) {
278         $sigil = '%';
279     }
280     else {
281         $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", type_constraint => $type_constraint );
282     }
283
284     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
285 }
286
287 1;
288
289 __END__
290
291 =pod
292
293 =head1 NAME
294
295 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
296
297 =head1 DESCRIPTION
298
299 This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
300 responsibility is to generate the accessor methods for attributes. It
301 can handle both closure based accessors, as well as inlined source based
302 accessors.
303
304 This is a fairly new addition to the MOP, but this will play an important
305 role in the optimization strategy we are currently following.
306
307 =head1 METHODS
308
309 =over 4
310
311 =item B<generate_accessor_method>
312
313 =item B<generate_reader_method>
314
315 =item B<generate_writer_method>
316
317 =item B<generate_predicate_method>
318
319 =item B<generate_clearer_method>
320
321 =item B<generate_accessor_method_inline>
322
323 =item B<generate_reader_method_inline>
324
325 =item B<generate_writer_method_inline>
326
327 =back
328
329 =head1 BUGS
330
331 All complex software has bugs lurking in it, and this module is no
332 exception. If you find a bug please either email me, or add the bug
333 to cpan-RT.
334
335 =head1 AUTHOR
336
337 Stevan Little E<lt>stevan@iinteractive.comE<gt>
338
339 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
340
341 =head1 COPYRIGHT AND LICENSE
342
343 Copyright 2006-2009 by Infinity Interactive, Inc.
344
345 L<http://www.iinteractive.com>
346
347 This library is free software; you can redistribute it and/or modify
348 it under the same terms as Perl itself.
349
350 =cut