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