text tweaklets (I always write a lot of hand-waving when I should just say "do X")
[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor.pm
CommitLineData
8ee73eeb 1
2package Moose::Meta::Method::Accessor;
3
4use strict;
5use warnings;
6
4b2189ce 7our $VERSION = '0.72';
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;
97e11ef5 220
eae37c67 221 my $code = $mi->inline_set_slot_value($instance, $attr->slots, $value) . ";";
222 $code .= $mi->inline_weaken_slot_value($instance, $attr->slots, $value) . ";"
97e11ef5 223 if $attr->is_weak_ref;
d617b644 224 return $code;
225}
226
227sub _inline_trigger {
97e11ef5 228 my ($self, $instance, $value) = @_;
229 my $attr = $self->associated_attribute;
230 return '' unless $attr->has_trigger;
ec2e2ee5 231 return sprintf('$attr->trigger->(%s, %s);', $instance, $value);
d617b644 232}
233
234sub _inline_get {
97e11ef5 235 my ($self, $instance) = @_;
236 my $attr = $self->associated_attribute;
237
238 my $mi = $attr->associated_class->get_meta_instance;
d617b644 239
eae37c67 240 return $mi->inline_get_slot_value($instance, $attr->slots);
d617b644 241}
242
e27dfc11 243sub _inline_access {
97e11ef5 244 my ($self, $instance) = @_;
245 my $attr = $self->associated_attribute;
246
247 my $mi = $attr->associated_class->get_meta_instance;
e27dfc11 248
eae37c67 249 return $mi->inline_slot_access($instance, $attr->slots);
e27dfc11 250}
251
252sub _inline_has {
97e11ef5 253 my ($self, $instance) = @_;
254 my $attr = $self->associated_attribute;
255
256 my $mi = $attr->associated_class->get_meta_instance;
e27dfc11 257
eae37c67 258 return $mi->inline_is_slot_initialized($instance, $attr->slots);
e27dfc11 259}
260
d617b644 261sub _inline_auto_deref {
262 my ( $self, $ref_value ) = @_;
26fbace8 263 my $attr = $self->associated_attribute;
d617b644 264
39b3bc94 265 return $ref_value unless $attr->should_auto_deref;
d617b644 266
39b3bc94 267 my $type_constraint = $attr->type_constraint;
d617b644 268
269 my $sigil;
270 if ($type_constraint->is_a_type_of('ArrayRef')) {
271 $sigil = '@';
26fbace8 272 }
d617b644 273 elsif ($type_constraint->is_a_type_of('HashRef')) {
274 $sigil = '%';
26fbace8 275 }
d617b644 276 else {
46cb090f 277 $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", type_constraint => $type_constraint );
d617b644 278 }
279
280 "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
281}
8ee73eeb 282
2831;
284
285__END__
286
287=pod
288
39b3bc94 289=head1 NAME
290
ecb59493 291Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
39b3bc94 292
293=head1 DESCRIPTION
294
26fbace8 295This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
296responsibility is to generate the accessor methods for attributes. It
ecb59493 297can handle both closure based accessors, as well as inlined source based
26fbace8 298accessors.
ecb59493 299
300This is a fairly new addition to the MOP, but this will play an important
301role in the optimization strategy we are currently following.
302
39b3bc94 303=head1 METHODS
304
305=over 4
306
8ecb1fa0 307=item B<generate_accessor_method>
308
309=item B<generate_reader_method>
310
311=item B<generate_writer_method>
312
7975db4f 313=item B<generate_predicate_method>
314
315=item B<generate_clearer_method>
316
39b3bc94 317=item B<generate_accessor_method_inline>
318
39b3bc94 319=item B<generate_reader_method_inline>
320
39b3bc94 321=item B<generate_writer_method_inline>
322
323=back
324
325=head1 BUGS
326
26fbace8 327All complex software has bugs lurking in it, and this module is no
39b3bc94 328exception. If you find a bug please either email me, or add the bug
329to cpan-RT.
330
331=head1 AUTHOR
332
333Stevan Little E<lt>stevan@iinteractive.comE<gt>
334
335Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
336
337=head1 COPYRIGHT AND LICENSE
338
2840a3b2 339Copyright 2006-2009 by Infinity Interactive, Inc.
39b3bc94 340
341L<http://www.iinteractive.com>
342
343This library is free software; you can redistribute it and/or modify
344it under the same terms as Perl itself.
345
51308c23 346=cut