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