add some more tests (including some TODOs)
[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor.pm
CommitLineData
8ee73eeb 1
2package Moose::Meta::Method::Accessor;
3
4use strict;
5use warnings;
6
b6cca0d5 7our $VERSION = '1.14';
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 {
34aab661 20 my ( $self, $source ) = @_;
c9183ffc 21
f5f08b5f 22 my $environment = $self->_eval_environment;
c9183ffc 23
34aab661 24 my ( $code, $e ) = $self->_compile_code( environment => $environment, code => $source );
25
26 $self->throw_error(
27 "Could not create writer for '${\$self->associated_attribute->name}' because $e \n code: $source",
28 error => $e, data => $source )
29 if $e;
30
31 return $code;
c9183ffc 32}
33
f5f08b5f 34sub _eval_environment {
35 my $self = shift;
36
37 my $attr = $self->associated_attribute;
38 my $type_constraint_obj = $attr->type_constraint;
39
40 return {
41 '$attr' => \$attr,
42 '$meta' => \$self,
43 '$type_constraint_obj' => \$type_constraint_obj,
44 '$type_constraint' => \(
45 $type_constraint_obj
46 ? $type_constraint_obj->_compiled_type_constraint
47 : undef
48 ),
49 };
50}
51
6a4a7c31 52sub _generate_accessor_method_inline {
3ccdc84a 53 my $self = $_[0];
26fbace8 54 my $attr = $self->associated_attribute;
3ccdc84a 55 my $inv = '$_[0]';
ac211120 56 my $value_name = $self->_value_needs_copy ? '$val' : '$_[1]';
d617b644 57
c9183ffc 58 $self->_eval_code('sub { ' . "\n"
e27dfc11 59 . $self->_inline_pre_body(@_) . "\n"
e7c06c1e 60 . 'if (scalar(@_) >= 2) {' . "\n"
ac211120 61 . $self->_inline_copy_value . "\n"
e27dfc11 62 . $self->_inline_check_required . "\n"
641e2264 63 . $self->_inline_check_coercion($value_name) . "\n"
e27dfc11 64 . $self->_inline_check_constraint($value_name) . "\n"
3dda07f5 65 . $self->_inline_get_old_value_for_trigger($inv, $value_name) . "\n"
32dd4a95 66 . $self->_inline_store($inv, $value_name) . "\n"
3dda07f5 67 . $self->_inline_trigger($inv, $value_name, '@old') . "\n"
e27dfc11 68 . ' }' . "\n"
e606ae5f 69 . $self->_inline_check_lazy($inv) . "\n"
e27dfc11 70 . $self->_inline_post_body(@_) . "\n"
71 . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
c9183ffc 72 . ' }');
d617b644 73}
74
6a4a7c31 75sub _generate_writer_method_inline {
3ccdc84a 76 my $self = $_[0];
26fbace8 77 my $attr = $self->associated_attribute;
3ccdc84a 78 my $inv = '$_[0]';
95d922a2 79 my $slot_access = $self->_inline_get($inv);
ac211120 80 my $value_name = $self->_value_needs_copy ? '$val' : '$_[1]';
3ccdc84a 81
c9183ffc 82 $self->_eval_code('sub { '
c350159f 83 . $self->_inline_pre_body(@_)
ac211120 84 . $self->_inline_copy_value
d617b644 85 . $self->_inline_check_required
641e2264 86 . $self->_inline_check_coercion($value_name)
32dd4a95 87 . $self->_inline_check_constraint($value_name)
3dda07f5 88 . $self->_inline_get_old_value_for_trigger($inv, $value_name) . "\n"
32dd4a95 89 . $self->_inline_store($inv, $value_name)
90 . $self->_inline_post_body(@_)
3dda07f5 91 . $self->_inline_trigger($inv, $value_name, '@old')
c9183ffc 92 . ' }');
d617b644 93}
94
6a4a7c31 95sub _generate_reader_method_inline {
3ccdc84a 96 my $self = $_[0];
26fbace8 97 my $attr = $self->associated_attribute;
3ccdc84a 98 my $inv = '$_[0]';
95d922a2 99 my $slot_access = $self->_inline_get($inv);
26fbace8 100
c9183ffc 101 $self->_eval_code('sub {'
c350159f 102 . $self->_inline_pre_body(@_)
cee532a1 103 . $self->_inline_throw_error('"Cannot assign a value to a read-only accessor"', 'data => \@_') . ' if @_ > 1;'
e606ae5f 104 . $self->_inline_check_lazy($inv)
c350159f 105 . $self->_inline_post_body(@_)
3ccdc84a 106 . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
c9183ffc 107 . '}');
d617b644 108}
109
ac211120 110sub _inline_copy_value {
111 return '' unless shift->_value_needs_copy;
112 return 'my $val = $_[1];'
113}
114
115sub _value_needs_copy {
116 my $attr = (shift)->associated_attribute;
117 return $attr->should_coerce;
118}
119
f001c60f 120sub _instance_is_inlinable {
121 my $self = shift;
122 return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
123}
124
125sub _generate_reader_method {
126 my $self = shift;
127 $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_)
128 : $self->SUPER::_generate_reader_method(@_);
129}
130
131sub _generate_writer_method {
132 my $self = shift;
133 $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_)
134 : $self->SUPER::_generate_writer_method(@_);
135}
136
137sub _generate_accessor_method {
138 my $self = shift;
139 $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_)
140 : $self->SUPER::_generate_accessor_method(@_);
141}
142
143sub _generate_predicate_method {
144 my $self = shift;
145 $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_)
146 : $self->SUPER::_generate_predicate_method(@_);
147}
148
149sub _generate_clearer_method {
150 my $self = shift;
151 $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_)
152 : $self->SUPER::_generate_clearer_method(@_);
153}
8ecb1fa0 154
3ccdc84a 155sub _inline_pre_body { '' }
c350159f 156sub _inline_post_body { '' }
157
d617b644 158sub _inline_check_constraint {
97e11ef5 159 my ($self, $value) = @_;
d03bd989 160
97e11ef5 161 my $attr = $self->associated_attribute;
d03bd989 162
97e11ef5 163 return '' unless $attr->has_type_constraint;
d03bd989 164
95d922a2 165 my $attr_name = quotemeta( $attr->name );
8bb7da15 166
cee532a1 167 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 168}
169
170sub _inline_check_coercion {
641e2264 171 my ($self, $value) = @_;
172
173 my $attr = $self->associated_attribute;
d03bd989 174
bb8afe3d 175 return '' unless $attr->should_coerce && $attr->type_constraint->has_coercion;
641e2264 176 return "$value = \$attr->type_constraint->coerce($value);";
d617b644 177}
178
179sub _inline_check_required {
cee532a1 180 my $self = shift;
181 my $attr = $self->associated_attribute;
8bb7da15 182
97e11ef5 183 return '' unless $attr->is_required;
95d922a2 184
185 my $attr_name = quotemeta( $attr->name );
186
cee532a1 187 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 188}
189
190sub _inline_check_lazy {
e606ae5f 191 my ($self, $instance) = @_;
192
26fbace8 193 my $attr = $self->associated_attribute;
194
3822d5ee 195 return '' unless $attr->is_lazy;
26fbace8 196
95d922a2 197 my $slot_exists = $self->_inline_has($instance);
3822d5ee 198
199 my $code = 'unless (' . $slot_exists . ') {' . "\n";
200 if ($attr->has_type_constraint) {
97e11ef5 201 if ($attr->has_default || $attr->has_builder) {
202 if ($attr->has_default) {
e606ae5f 203 $code .= ' my $default = $attr->default(' . $instance . ');'."\n";
d03bd989 204 }
97e11ef5 205 elsif ($attr->has_builder) {
3822d5ee 206 $code .= ' my $default;'."\n".
e606ae5f 207 ' if(my $builder = '.$instance.'->can($attr->builder)){ '."\n".
208 ' $default = '.$instance.'->$builder; '. "\n } else {\n" .
209 ' ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name') .
210 ';'. "\n }";
3822d5ee 211 }
641e2264 212 $code .= $self->_inline_check_coercion('$default') . "\n";
213 $code .= $self->_inline_check_constraint('$default') . "\n";
909405b8 214 $code .= ' ' . $self->_inline_init_slot($attr, $instance, '$default') . "\n";
d03bd989 215 }
97e11ef5 216 else {
909405b8 217 $code .= ' ' . $self->_inline_init_slot($attr, $instance, 'undef') . "\n";
26fbace8 218 }
219
3822d5ee 220 } else {
97e11ef5 221 if ($attr->has_default) {
909405b8 222 $code .= ' ' . $self->_inline_init_slot($attr, $instance, ('$attr->default(' . $instance . ')')) . "\n";
d03bd989 223 }
97e11ef5 224 elsif ($attr->has_builder) {
d03bd989 225 $code .= ' if (my $builder = '.$instance.'->can($attr->builder)) { ' . "\n"
909405b8 226 . ' ' . $self->_inline_init_slot($attr, $instance, ($instance . '->$builder'))
e606ae5f 227 . "\n } else {\n"
228 . ' ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name')
229 . ';'. "\n }";
d03bd989 230 }
97e11ef5 231 else {
909405b8 232 $code .= ' ' . $self->_inline_init_slot($attr, $instance, 'undef') . "\n";
3822d5ee 233 }
234 }
235 $code .= "}\n";
236 return $code;
d617b644 237}
238
9df136d0 239sub _inline_init_slot {
909405b8 240 my ($self, $attr, $inv, $value) = @_;
9df136d0 241 if ($attr->has_initializer) {
242 return ('$attr->set_initial_value(' . $inv . ', ' . $value . ');');
243 }
244 else {
909405b8 245 return $self->_inline_store($inv, $value);
d03bd989 246 }
9df136d0 247}
d617b644 248
249sub _inline_store {
d67398ab 250 my ( $self, $instance, $value ) = @_;
d03bd989 251
e06951bb 252 return $self->associated_attribute->inline_set( $instance, $value );
d617b644 253}
254
3dda07f5 255sub _inline_get_old_value_for_trigger {
256 my ( $self, $instance ) = @_;
257
258 my $attr = $self->associated_attribute;
259 return '' unless $attr->has_trigger;
260
3dda07f5 261 return
262 'my @old = '
d67398ab 263 . $self->_inline_has($instance) . q{ ? }
3dda07f5 264 . $self->_inline_get($instance) . q{ : ()} . ";\n";
265}
266
d617b644 267sub _inline_trigger {
3dda07f5 268 my ($self, $instance, $value, $old_value) = @_;
97e11ef5 269 my $attr = $self->associated_attribute;
270 return '' unless $attr->has_trigger;
3dda07f5 271 return sprintf('$attr->trigger->(%s, %s, %s);', $instance, $value, $old_value);
d617b644 272}
273
274sub _inline_get {
97e11ef5 275 my ($self, $instance) = @_;
d03bd989 276
d67398ab 277 return $self->associated_attribute->inline_get($instance);
d617b644 278}
279
e27dfc11 280sub _inline_has {
97e11ef5 281 my ($self, $instance) = @_;
e27dfc11 282
d67398ab 283 return $self->associated_attribute->inline_has($instance);
e27dfc11 284}
285
d617b644 286sub _inline_auto_deref {
287 my ( $self, $ref_value ) = @_;
26fbace8 288 my $attr = $self->associated_attribute;
d617b644 289
39b3bc94 290 return $ref_value unless $attr->should_auto_deref;
d617b644 291
39b3bc94 292 my $type_constraint = $attr->type_constraint;
d617b644 293
294 my $sigil;
295 if ($type_constraint->is_a_type_of('ArrayRef')) {
296 $sigil = '@';
26fbace8 297 }
d617b644 298 elsif ($type_constraint->is_a_type_of('HashRef')) {
299 $sigil = '%';
26fbace8 300 }
d617b644 301 else {
95d922a2 302 $self->throw_error( "Can not auto de-reference the type constraint '"
303 . quotemeta( $type_constraint->name )
304 . "'", type_constraint => $type_constraint );
d617b644 305 }
306
307 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
308}
8ee73eeb 309
3101;
311
312__END__
313
314=pod
315
39b3bc94 316=head1 NAME
317
ecb59493 318Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
39b3bc94 319
320=head1 DESCRIPTION
321
ba4dfb8e 322This class is a subclass of L<Class::MOP::Method::Accessor> that
73f769fc 323provides additional Moose-specific functionality, all of which is
324private.
ecb59493 325
73f769fc 326To understand this class, you should read the the
ba4dfb8e 327L<Class::MOP::Method::Accessor> documentation.
39b3bc94 328
329=head1 BUGS
330
d4048ef3 331See L<Moose/BUGS> for details on reporting bugs.
39b3bc94 332
333=head1 AUTHOR
334
335Stevan Little E<lt>stevan@iinteractive.comE<gt>
336
337Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
338
339=head1 COPYRIGHT AND LICENSE
340
7e0492d3 341Copyright 2006-2010 by Infinity Interactive, Inc.
39b3bc94 342
343L<http://www.iinteractive.com>
344
345This library is free software; you can redistribute it and/or modify
346it under the same terms as Perl itself.
347
51308c23 348=cut