Make sure attr conflict error includes attr name
[gitmo/Moose.git] / lib / Moose / Meta / Attribute.pm
CommitLineData
c0e30cf5 1
2package Moose::Meta::Attribute;
3
4use strict;
5use warnings;
6
9238220f 7use Class::MOP ();
21f1e231 8use Scalar::Util 'blessed', 'weaken';
fe11f190 9use List::MoreUtils 'any';
1454efcc 10use Try::Tiny;
a909a4df 11use overload ();
a15dff8d 12
bb09ad91 13our $VERSION = '1.17';
d44714be 14our $AUTHORITY = 'cpan:STEVAN';
78cd1d3b 15
f1309155 16use Moose::Deprecated;
8ee73eeb 17use Moose::Meta::Method::Accessor;
a05f85c1 18use Moose::Meta::Method::Delegation;
d5c30e52 19use Moose::Util ();
a3c7e2fe 20use Moose::Util::TypeConstraints ();
d2782813 21use Class::MOP::MiniTrait;
bc1e29b5 22
f785aad8 23use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
c0e30cf5 24
d2782813 25Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
26
82a5b1a7 27__PACKAGE__->meta->add_attribute('traits' => (
28 reader => 'applied_traits',
29 predicate => 'has_applied_traits',
30));
82168dbb 31
d03bd989 32# we need to have a ->does method in here to
33# more easily support traits, and the introspection
0db4f1d7 34# of those traits. We extend the does check to look
35# for metatrait aliases.
36sub does {
37 my ($self, $role_name) = @_;
1454efcc 38 my $name = try {
0db4f1d7 39 Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
40 };
41 return 0 if !defined($name); # failed to load class
e8895723 42 return $self->Moose::Object::does($name);
0db4f1d7 43}
587e457d 44
be05faea 45sub throw_error {
46 my $self = shift;
47 my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
48 unshift @_, "message" if @_ % 2 == 1;
49 unshift @_, attr => $self if ref $self;
50 unshift @_, $class;
18748ad6 51 my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1
52 goto $handler;
be05faea 53}
54
78cd1d3b 55sub new {
f3c4e20e 56 my ($class, $name, %options) = @_;
c32c2c61 57 $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
aa4c3a8d 58
59 delete $options{__hack_no_process_options};
60
61 my %attrs =
62 ( map { $_ => 1 }
63 grep { defined }
64 map { $_->init_arg() }
65 $class->meta()->get_all_attributes()
66 );
67
68 my @bad = sort grep { ! $attrs{$_} } keys %options;
69
70 if (@bad)
71 {
72 Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
73 }
74
f3c4e20e 75 return $class->SUPER::new($name, %options);
1d768fb1 76}
77
d5c30e52 78sub interpolate_class_and_new {
aa4c3a8d 79 my ($class, $name, %args) = @_;
d5c30e52 80
aa4c3a8d 81 my ( $new_class, @traits ) = $class->interpolate_class(\%args);
d03bd989 82
aa4c3a8d 83 $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
d5c30e52 84}
85
86sub interpolate_class {
aa4c3a8d 87 my ($class, $options) = @_;
d5c30e52 88
c32c2c61 89 $class = ref($class) || $class;
90
aa4c3a8d 91 if ( my $metaclass_name = delete $options->{metaclass} ) {
c32c2c61 92 my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
d03bd989 93
c32c2c61 94 if ( $class ne $new_class ) {
95 if ( $new_class->can("interpolate_class") ) {
aa4c3a8d 96 return $new_class->interpolate_class($options);
c32c2c61 97 } else {
98 $class = $new_class;
99 }
100 }
d5c30e52 101 }
102
c32c2c61 103 my @traits;
104
aa4c3a8d 105 if (my $traits = $options->{traits}) {
8974015d 106 my $i = 0;
107 while ($i < @$traits) {
108 my $trait = $traits->[$i++];
109 next if ref($trait); # options to a trait we discarded
110
111 $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
112 || $trait;
113
114 next if $class->does($trait);
115
116 push @traits, $trait;
117
118 # are there options?
119 push @traits, $traits->[$i++]
120 if $traits->[$i] && ref($traits->[$i]);
121 }
965743fb 122
123 if (@traits) {
c32c2c61 124 my $anon_class = Moose::Meta::Class->create_anon_class(
125 superclasses => [ $class ],
126 roles => [ @traits ],
127 cache => 1,
128 );
129
130 $class = $anon_class->name;
131 }
d5c30e52 132 }
c32c2c61 133
134 return ( wantarray ? ( $class, @traits ) : $class );
d5c30e52 135}
136
e606ae5f 137# ...
138
ec835085 139# method-generating options shouldn't be overridden
140sub illegal_options_for_inheritance {
d21262bd 141 qw(reader writer accessor clearer predicate)
ec835085 142}
e606ae5f 143
144# NOTE/TODO
d03bd989 145# This method *must* be able to handle
146# Class::MOP::Attribute instances as
147# well. Yes, I know that is wrong, but
148# apparently we didn't realize it was
149# doing that and now we have some code
150# which is dependent on it. The real
151# solution of course is to push this
e606ae5f 152# feature back up into Class::MOP::Attribute
153# but I not right now, I am too lazy.
d03bd989 154# However if you are reading this and
155# looking for something to do,.. please
e606ae5f 156# be my guest.
157# - stevan
ce0e8d63 158sub clone_and_inherit_options {
159 my ($self, %options) = @_;
d03bd989 160
e606ae5f 161 # NOTE:
162 # we may want to extends a Class::MOP::Attribute
d03bd989 163 # in which case we need to be able to use the
164 # core set of legal options that have always
e606ae5f 165 # been here. But we allows Moose::Meta::Attribute
166 # instances to changes them.
167 # - SL
7782e1da 168 my @illegal_options = $self->can('illegal_options_for_inheritance')
169 ? $self->illegal_options_for_inheritance
170 : ();
171
ec835085 172 my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
7782e1da 173 (scalar @found_illegal_options == 0)
174 || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
26fbace8 175
ce0e8d63 176 if ($options{isa}) {
177 my $type_constraint;
8de73ff1 178 if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
179 $type_constraint = $options{isa};
180 }
181 else {
d40ce9d5 182 $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
8de73ff1 183 (defined $type_constraint)
be05faea 184 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
8de73ff1 185 }
5e98d2b6 186
7782e1da 187 $options{type_constraint} = $type_constraint;
ce0e8d63 188 }
d03bd989 189
2ea379cb 190 if ($options{does}) {
191 my $type_constraint;
192 if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
193 $type_constraint = $options{does};
194 }
195 else {
d40ce9d5 196 $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
2ea379cb 197 (defined $type_constraint)
be05faea 198 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
2ea379cb 199 }
200
7782e1da 201 $options{type_constraint} = $type_constraint;
d03bd989 202 }
c32c2c61 203
cbd141ca 204 # NOTE:
d03bd989 205 # this doesn't apply to Class::MOP::Attributes,
cbd141ca 206 # so we can ignore it for them.
207 # - SL
208 if ($self->can('interpolate_class')) {
7782e1da 209 ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
c32c2c61 210
cbd141ca 211 my %seen;
212 my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
7782e1da 213 $options{traits} = \@all_traits if @all_traits;
cbd141ca 214 }
c32c2c61 215
4a8c7092 216 $self->_modify_attr_options_for_lazy_build( $self->name, \%options );
217
7782e1da 218 $self->clone(%options);
1d768fb1 219}
220
c32c2c61 221sub clone {
222 my ( $self, %params ) = @_;
223
aa4c3a8d 224 my $class = delete $params{metaclass} || ref $self;
c32c2c61 225
db72153d 226 my ( @init, @non_init );
c32c2c61 227
0772362a 228 foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
db72153d 229 push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
230 }
c32c2c61 231
db72153d 232 my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
c32c2c61 233
db72153d 234 my $name = delete $new_params{name};
c32c2c61 235
db72153d 236 my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
c32c2c61 237
db72153d 238 foreach my $attr ( @non_init ) {
239 $attr->set_value($clone, $attr->get_value($self));
c32c2c61 240 }
db72153d 241
242 return $clone;
c32c2c61 243}
244
1d768fb1 245sub _process_options {
246 my ($class, $name, $options) = @_;
8de73ff1 247
f3c4e20e 248 if (exists $options->{is}) {
21f1e231 249
012fcbd1 250 ### -------------------------
251 ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
252 ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
253 ## is => rw, accessor => _foo # turns into (accessor => _foo)
254 ## is => ro, accessor => _foo # error, accesor is rw
255 ### -------------------------
d03bd989 256
8de73ff1 257 if ($options->{is} eq 'ro') {
be05faea 258 $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
21f1e231 259 if exists $options->{accessor};
8de73ff1 260 $options->{reader} ||= $name;
8de73ff1 261 }
262 elsif ($options->{is} eq 'rw') {
21f1e231 263 if ($options->{writer}) {
264 $options->{reader} ||= $name;
265 }
266 else {
267 $options->{accessor} ||= $name;
268 }
8de73ff1 269 }
ccd4cff9 270 elsif ($options->{is} eq 'bare') {
271 # do nothing, but don't complain (later) about missing methods
272 }
8de73ff1 273 else {
e606ae5f 274 $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
8de73ff1 275 }
f3c4e20e 276 }
8de73ff1 277
f3c4e20e 278 if (exists $options->{isa}) {
f3c4e20e 279 if (exists $options->{does}) {
1454efcc 280 if (try { $options->{isa}->can('does') }) {
f3c4e20e 281 ($options->{isa}->does($options->{does}))
e606ae5f 282 || $class->throw_error("Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)", data => $options);
f3c4e20e 283 }
284 else {
e606ae5f 285 $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
26fbace8 286 }
26fbace8 287 }
8de73ff1 288
f3c4e20e 289 # allow for anon-subtypes here ...
290 if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
8de73ff1 291 $options->{type_constraint} = $options->{isa};
292 }
293 else {
620db045 294 $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
8de73ff1 295 }
f3c4e20e 296 }
297 elsif (exists $options->{does}) {
298 # allow for anon-subtypes here ...
299 if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
238b424d 300 $options->{type_constraint} = $options->{does};
8de73ff1 301 }
302 else {
620db045 303 $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
8de73ff1 304 }
f3c4e20e 305 }
8de73ff1 306
f3c4e20e 307 if (exists $options->{coerce} && $options->{coerce}) {
308 (exists $options->{type_constraint})
e606ae5f 309 || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options);
310 $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options)
8de73ff1 311 if $options->{weak_ref};
2b54d2a6 312
470bc652 313 unless ( $options->{type_constraint}->has_coercion ) {
314 my $type = $options->{type_constraint}->name;
f1309155 315
316 Moose::Deprecated::deprecated(
317 feature => 'coerce without coercion',
318 message =>
319 "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
320 );
470bc652 321 }
f3c4e20e 322 }
8de73ff1 323
0b7df53c 324 if (exists $options->{trigger}) {
21f1e231 325 ('CODE' eq ref $options->{trigger})
e606ae5f 326 || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
0b7df53c 327 }
328
f3c4e20e 329 if (exists $options->{auto_deref} && $options->{auto_deref}) {
330 (exists $options->{type_constraint})
e606ae5f 331 || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options);
f3c4e20e 332 ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
8de73ff1 333 $options->{type_constraint}->is_a_type_of('HashRef'))
e606ae5f 334 || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options);
f3c4e20e 335 }
8de73ff1 336
4a8c7092 337 $class->_modify_attr_options_for_lazy_build( $name, $options );
8de73ff1 338
f3c4e20e 339 if (exists $options->{lazy} && $options->{lazy}) {
9edba990 340 (exists $options->{default} || defined $options->{builder} )
be05faea 341 || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
f3c4e20e 342 }
26fbace8 343
9edba990 344 if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
be05faea 345 $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
9edba990 346 }
347
78cd1d3b 348}
c0e30cf5 349
4a8c7092 350sub _modify_attr_options_for_lazy_build {
351 my ( $class, $name, $options ) = @_;
352
353 return unless $options->{lazy_build};
354
355 $class->throw_error(
356 "You can not use lazy_build and default for the same attribute ($name)",
357 data => $options )
358 if exists $options->{default};
359
360 $options->{lazy} = 1;
361 $options->{builder} ||= "_build_${name}";
362 if ( $name =~ /^_/ ) {
363 $options->{clearer} ||= "_clear${name}";
364 $options->{predicate} ||= "_has${name}";
365 }
366 else {
367 $options->{clearer} ||= "clear_${name}";
368 $options->{predicate} ||= "has_${name}";
369 }
370}
371
d500266f 372sub initialize_instance_slot {
ddd0ec20 373 my ($self, $meta_instance, $instance, $params) = @_;
d500266f 374 my $init_arg = $self->init_arg();
375 # try to fetch the init arg from the %params ...
ddd0ec20 376
26fbace8 377 my $val;
1ed0b94f 378 my $value_is_set;
625d571f 379 if ( defined($init_arg) and exists $params->{$init_arg}) {
d500266f 380 $val = $params->{$init_arg};
d03bd989 381 $value_is_set = 1;
d500266f 382 }
383 else {
384 # skip it if it's lazy
385 return if $self->is_lazy;
386 # and die if it's required and doesn't have a default value
be05faea 387 $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
26fbace8 388 if $self->is_required && !$self->has_default && !$self->has_builder;
ddd0ec20 389
1ed0b94f 390 # if nothing was in the %params, we can use the
391 # attribute's default value (if it has one)
392 if ($self->has_default) {
393 $val = $self->default($instance);
394 $value_is_set = 1;
d03bd989 395 }
a6c84c69 396 elsif ($self->has_builder) {
e606ae5f 397 $val = $self->_call_builder($instance);
398 $value_is_set = 1;
a0748c37 399 }
26fbace8 400 }
401
1ed0b94f 402 return unless $value_is_set;
403
9c9563c7 404 $val = $self->_coerce_and_verify( $val, $instance );
ddd0ec20 405
759e4e8f 406 $self->set_initial_value($instance, $val);
312e0f0c 407
408 if ( ref $val && $self->is_weak_ref ) {
32881f68 409 $self->_weaken_value($instance);
312e0f0c 410 }
d500266f 411}
412
e606ae5f 413sub _call_builder {
414 my ( $self, $instance ) = @_;
415
416 my $builder = $self->builder();
417
418 return $instance->$builder()
419 if $instance->can( $self->builder );
420
421 $self->throw_error( blessed($instance)
422 . " does not support builder method '"
423 . $self->builder
424 . "' for attribute '"
425 . $self->name
426 . "'",
427 object => $instance,
428 );
429}
430
d617b644 431## Slot management
9e93dd19 432
8abe9636 433# FIXME:
d03bd989 434# this duplicates too much code from
435# Class::MOP::Attribute, we need to
8abe9636 436# refactor these bits eventually.
437# - SL
438sub _set_initial_slot_value {
439 my ($self, $meta_instance, $instance, $value) = @_;
440
441 my $slot_name = $self->name;
442
443 return $meta_instance->set_slot_value($instance, $slot_name, $value)
444 unless $self->has_initializer;
445
8abe9636 446 my $callback = sub {
9c9563c7 447 my $val = $self->_coerce_and_verify( shift, $instance );;
448
8abe9636 449 $meta_instance->set_slot_value($instance, $slot_name, $val);
450 };
d03bd989 451
8abe9636 452 my $initializer = $self->initializer;
453
454 # most things will just want to set a value, so make it first arg
455 $instance->$initializer($value, $callback, $self);
456}
457
946289d1 458sub set_value {
b6af66f8 459 my ($self, $instance, @args) = @_;
460 my $value = $args[0];
26fbace8 461
946289d1 462 my $attr_name = $self->name;
26fbace8 463
b6af66f8 464 if ($self->is_required and not @args) {
be05faea 465 $self->throw_error("Attribute ($attr_name) is required", object => $instance);
946289d1 466 }
26fbace8 467
9c9563c7 468 $value = $self->_coerce_and_verify( $value, $instance );
26fbace8 469
3dda07f5 470 my @old;
471 if ( $self->has_trigger && $self->has_value($instance) ) {
472 @old = $self->get_value($instance, 'for trigger');
473 }
474
312e0f0c 475 $self->SUPER::set_value($instance, $value);
26fbace8 476
312e0f0c 477 if ( ref $value && $self->is_weak_ref ) {
32881f68 478 $self->_weaken_value($instance);
946289d1 479 }
26fbace8 480
946289d1 481 if ($self->has_trigger) {
3dda07f5 482 $self->trigger->($instance, $value, @old);
946289d1 483 }
484}
485
32881f68 486sub _weaken_value {
312e0f0c 487 my ( $self, $instance ) = @_;
488
32881f68 489 my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
490 ->get_meta_instance;
312e0f0c 491
492 $meta_instance->weaken_slot_value( $instance, $self->name );
493}
494
946289d1 495sub get_value {
3dda07f5 496 my ($self, $instance, $for_trigger) = @_;
26fbace8 497
946289d1 498 if ($self->is_lazy) {
8de73ff1 499 unless ($self->has_value($instance)) {
e606ae5f 500 my $value;
8de73ff1 501 if ($self->has_default) {
e606ae5f 502 $value = $self->default($instance);
3f11800d 503 } elsif ( $self->has_builder ) {
e606ae5f 504 $value = $self->_call_builder($instance);
505 }
9c9563c7 506
507 $value = $self->_coerce_and_verify( $value, $instance );
508
e606ae5f 509 $self->set_initial_value($instance, $value);
8de73ff1 510 }
946289d1 511 }
26fbace8 512
3dda07f5 513 if ( $self->should_auto_deref && ! $for_trigger ) {
26fbace8 514
946289d1 515 my $type_constraint = $self->type_constraint;
516
517 if ($type_constraint->is_a_type_of('ArrayRef')) {
518 my $rv = $self->SUPER::get_value($instance);
519 return unless defined $rv;
520 return wantarray ? @{ $rv } : $rv;
26fbace8 521 }
946289d1 522 elsif ($type_constraint->is_a_type_of('HashRef')) {
523 my $rv = $self->SUPER::get_value($instance);
524 return unless defined $rv;
525 return wantarray ? %{ $rv } : $rv;
26fbace8 526 }
946289d1 527 else {
46cb090f 528 $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
946289d1 529 }
26fbace8 530
946289d1 531 }
532 else {
26fbace8 533
946289d1 534 return $self->SUPER::get_value($instance);
26fbace8 535 }
946289d1 536}
a15dff8d 537
26fbace8 538## installing accessors
c0e30cf5 539
246bbeef 540sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
541
542sub install_accessors {
ae907ae0 543 my $self = shift;
246bbeef 544 $self->SUPER::install_accessors(@_);
545 $self->install_delegation if $self->has_handles;
28af3424 546 return;
547}
548
9340e346 549sub _check_associated_methods {
28af3424 550 my $self = shift;
86cf196b 551 unless (
0bbd378f 552 @{ $self->associated_methods }
86cf196b 553 || ($self->_is_metadata || '') eq 'bare'
554 ) {
555 Carp::cluck(
8f4450f3 556 'Attribute (' . $self->name . ') of class '
557 . $self->associated_class->name
558 . ' has no associated methods'
86cf196b 559 . ' (did you mean to provide an "is" argument?)'
560 . "\n"
561 )
562 }
e606ae5f 563}
26fbace8 564
3b6e2290 565sub _process_accessors {
566 my $self = shift;
567 my ($type, $accessor, $generate_as_inline_methods) = @_;
568 $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH';
99541dfd 569 my $method = $self->associated_class->get_method($accessor);
570 if ($method && !$method->isa('Class::MOP::Method::Accessor')
571 && (!$self->definition_context
572 || $method->package_name eq $self->definition_context->{package})) {
3b6e2290 573 Carp::cluck(
1d18c898 574 "You are overwriting a locally defined method ($accessor) with "
3b6e2290 575 . "an accessor"
576 );
577 }
3968746e 578 if (!$self->associated_class->has_method($accessor)
579 && $self->associated_class->has_package_symbol('&' . $accessor)) {
580 Carp::cluck(
581 "You are overwriting a locally defined function ($accessor) with "
582 . "an accessor"
583 );
584 }
3b6e2290 585 $self->SUPER::_process_accessors(@_);
e606ae5f 586}
26fbace8 587
e1d6f0a3 588sub remove_accessors {
589 my $self = shift;
590 $self->SUPER::remove_accessors(@_);
591 $self->remove_delegation if $self->has_handles;
592 return;
593}
594
e06951bb 595sub inline_set {
d67398ab 596 my $self = shift;
597 my ( $instance, $value ) = @_;
598
599 my $mi = $self->associated_class->get_meta_instance;
600
601 my $code
602 = $mi->inline_set_slot_value( $instance, $self->slots, $value ) . ";";
603 $code
604 .= $mi->inline_weaken_slot_value( $instance, $self->slots, $value )
6e642c8f 605 . " if ref $value;"
d67398ab 606 if $self->is_weak_ref;
607
608 return $code;
609}
610
e606ae5f 611sub install_delegation {
612 my $self = shift;
26fbace8 613
e606ae5f 614 # NOTE:
615 # Here we canonicalize the 'handles' option
616 # this will sort out any details and always
617 # return an hash of methods which we want
618 # to delagate to, see that method for details
619 my %handles = $self->_canonicalize_handles;
620
e606ae5f 621
622 # install the delegation ...
623 my $associated_class = $self->associated_class;
624 foreach my $handle (keys %handles) {
625 my $method_to_call = $handles{$handle};
626 my $class_name = $associated_class->name;
627 my $name = "${class_name}::${handle}";
26fbace8 628
452bac1b 629 (!$associated_class->has_method($handle))
cee532a1 630 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
26fbace8 631
e606ae5f 632 # NOTE:
633 # handles is not allowed to delegate
634 # any of these methods, as they will
635 # override the ones in your class, which
636 # is almost certainly not what you want.
4fe78472 637
e606ae5f 638 # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
639 #cluck("Not delegating method '$handle' because it is a core method") and
640 next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
26fbace8 641
46f7e6a5 642 my $method = $self->_make_delegation_method($handle, $method_to_call);
a05f85c1 643
644 $self->associated_class->add_method($method->name, $method);
0bbd378f 645 $self->associate_method($method);
d03bd989 646 }
452bac1b 647}
648
e1d6f0a3 649sub remove_delegation {
650 my $self = shift;
651 my %handles = $self->_canonicalize_handles;
652 my $associated_class = $self->associated_class;
653 foreach my $handle (keys %handles) {
684323b3 654 next unless any { $handle eq $_ }
655 map { $_->name }
656 @{ $self->associated_methods };
e1d6f0a3 657 $self->associated_class->remove_method($handle);
658 }
659}
660
98aae381 661# private methods to help delegation ...
662
452bac1b 663sub _canonicalize_handles {
664 my $self = shift;
665 my $handles = $self->handles;
c84f324f 666 if (my $handle_type = ref($handles)) {
667 if ($handle_type eq 'HASH') {
668 return %{$handles};
669 }
670 elsif ($handle_type eq 'ARRAY') {
671 return map { $_ => $_ } @{$handles};
672 }
673 elsif ($handle_type eq 'Regexp') {
674 ($self->has_type_constraint)
0286711b 675 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
26fbace8 676 return map { ($_ => $_) }
c84f324f 677 grep { /$handles/ } $self->_get_delegate_method_list;
678 }
679 elsif ($handle_type eq 'CODE') {
680 return $handles->($self, $self->_find_delegate_metaclass);
681 }
6cbf4a23 682 elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
683 return map { $_ => $_ } @{ $handles->methods };
684 }
c7761602 685 elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
686 $handles = $handles->role;
687 }
c84f324f 688 else {
be05faea 689 $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
c84f324f 690 }
452bac1b 691 }
c84f324f 692
c7761602 693 Class::MOP::load_class($handles);
694 my $role_meta = Class::MOP::class_of($handles);
d03bd989 695
c7761602 696 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
697 || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
698
699 return map { $_ => $_ }
ba7d613d 700 map { $_->name }
701 grep { !$_->isa('Class::MOP::Method::Meta') } (
702 $role_meta->_get_local_methods,
703 $role_meta->get_required_method_list,
c7761602 704 );
452bac1b 705}
706
452bac1b 707sub _get_delegate_method_list {
708 my $self = shift;
709 my $meta = $self->_find_delegate_metaclass;
710 if ($meta->isa('Class::MOP::Class')) {
e606ae5f 711 return map { $_->name } # NOTE: !never! delegate &meta
ba7d613d 712 grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
e606ae5f 713 $meta->get_all_methods;
452bac1b 714 }
715 elsif ($meta->isa('Moose::Meta::Role')) {
26fbace8 716 return $meta->get_method_list;
452bac1b 717 }
718 else {
be05faea 719 $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
452bac1b 720 }
721}
722
ccc2f11f 723sub _find_delegate_metaclass {
724 my $self = shift;
725 if (my $class = $self->_isa_metadata) {
9238220f 726 unless ( Class::MOP::is_class_loaded($class) ) {
727 $self->throw_error(
728 sprintf(
729 'The %s attribute is trying to delegate to a class which has not been loaded - %s',
730 $self->name, $class
731 )
732 );
733 }
ccc2f11f 734 # we might be dealing with a non-Moose class,
735 # and need to make our own metaclass. if there's
736 # already a metaclass, it will be returned
737 return Class::MOP::Class->initialize($class);
738 }
739 elsif (my $role = $self->_does_metadata) {
9238220f 740 unless ( Class::MOP::is_class_loaded($class) ) {
741 $self->throw_error(
742 sprintf(
743 'The %s attribute is trying to delegate to a role which has not been loaded - %s',
744 $self->name, $role
745 )
746 );
747 }
748
ccc2f11f 749 return Class::MOP::class_of($role);
750 }
751 else {
752 $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
753 }
754}
755
bd1226e2 756sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
757
a05f85c1 758sub _make_delegation_method {
46f7e6a5 759 my ( $self, $handle_name, $method_to_call ) = @_;
a05f85c1 760
3c573ca4 761 my @curried_arguments;
2de18801 762
3c573ca4 763 ($method_to_call, @curried_arguments) = @$method_to_call
2de18801 764 if 'ARRAY' eq ref($method_to_call);
765
bd1226e2 766 return $self->delegation_metaclass->new(
46f7e6a5 767 name => $handle_name,
768 package_name => $self->associated_class->name,
769 attribute => $self,
770 delegate_to_method => $method_to_call,
3c573ca4 771 curried_arguments => \@curried_arguments,
a05f85c1 772 );
773}
774
9c9563c7 775sub _coerce_and_verify {
776 my $self = shift;
777 my $val = shift;
778 my $instance = shift;
779
780 return $val unless $self->has_type_constraint;
781
2b54d2a6 782 $val = $self->type_constraint->coerce($val)
5aab256d 783 if $self->should_coerce && $self->type_constraint->has_coercion;
9c9563c7 784
785 $self->verify_against_type_constraint($val, instance => $instance);
786
787 return $val;
788}
789
5755a9b2 790sub verify_against_type_constraint {
2b86e02b 791 my $self = shift;
792 my $val = shift;
793
794 return 1 if !$self->has_type_constraint;
795
796 my $type_constraint = $self->type_constraint;
797
798 $type_constraint->check($val)
799 || $self->throw_error("Attribute ("
800 . $self->name
801 . ") does not pass the type constraint because: "
802 . $type_constraint->get_message($val), data => $val, @_);
803}
804
21f1e231 805package Moose::Meta::Attribute::Custom::Moose;
806sub register_implementation { 'Moose::Meta::Attribute' }
807
c0e30cf5 8081;
809
810__END__
811
812=pod
813
814=head1 NAME
815
6ba6d68c 816Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5 817
818=head1 DESCRIPTION
819
93a708fd 820This class is a subclass of L<Class::MOP::Attribute> that provides
821additional Moose-specific functionality.
6ba6d68c 822
7854b409 823To really understand this class, you will need to start with the
824L<Class::MOP::Attribute> documentation. This class can be understood
825as a set of additional features on top of the basic feature provided
826by that parent class.
e522431d 827
d4b1449e 828=head1 INHERITANCE
829
830C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
831
c0e30cf5 832=head1 METHODS
833
93a708fd 834Many of the documented below override methods in
835L<Class::MOP::Attribute> and add Moose specific features.
6ba6d68c 836
93a708fd 837=head2 Creation
6ba6d68c 838
c0e30cf5 839=over 4
840
93a708fd 841=item B<< Moose::Meta::Attribute->new(%options) >>
c0e30cf5 842
93a708fd 843This method overrides the L<Class::MOP::Attribute> constructor.
c32c2c61 844
93a708fd 845Many of the options below are described in more detail in the
846L<Moose::Manual::Attributes> document.
6e2840b7 847
93a708fd 848It adds the following options to the constructor:
d500266f 849
93a708fd 850=over 8
452bac1b 851
996b8c8d 852=item * is => 'ro', 'rw', 'bare'
e1d6f0a3 853
93a708fd 854This provides a shorthand for specifying the C<reader>, C<writer>, or
855C<accessor> names. If the attribute is read-only ('ro') then it will
856have a C<reader> method with the same attribute as the name.
e606ae5f 857
93a708fd 858If it is read-write ('rw') then it will have an C<accessor> method
859with the same name. If you provide an explicit C<writer> for a
860read-write attribute, then you will have a C<reader> with the same
861name as the attribute, and a C<writer> with the name you provided.
e1d6f0a3 862
996b8c8d 863Use 'bare' when you are deliberately not installing any methods
864(accessor, reader, etc.) associated with this attribute; otherwise,
865Moose will issue a deprecation warning when this attribute is added to a
9340e346 866metaclass.
996b8c8d 867
93a708fd 868=item * isa => $type
39b3bc94 869
93a708fd 870This option accepts a type. The type can be a string, which should be
871a type name. If the type name is unknown, it is assumed to be a class
872name.
873
874This option can also accept a L<Moose::Meta::TypeConstraint> object.
875
876If you I<also> provide a C<does> option, then your C<isa> option must
877be a class name, and that class must do the role specified with
878C<does>.
879
880=item * does => $role
881
882This is short-hand for saying that the attribute's type must be an
883object which does the named role.
884
885=item * coerce => $bool
886
887This option is only valid for objects with a type constraint
3b98ba07 888(C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
93a708fd 889this attribute is set.
890
891You can make both this and the C<weak_ref> option true.
892
893=item * trigger => $sub
894
895This option accepts a subroutine reference, which will be called after
896the attribute is set.
897
898=item * required => $bool
899
900An attribute which is required must be provided to the constructor. An
901attribute which is required can also have a C<default> or C<builder>,
36741534 902which will satisfy its required-ness.
93a708fd 903
904A required attribute must have a C<default>, C<builder> or a
905non-C<undef> C<init_arg>
906
907=item * lazy => $bool
908
909A lazy attribute must have a C<default> or C<builder>. When an
910attribute is lazy, the default value will not be calculated until the
911attribute is read.
912
913=item * weak_ref => $bool
914
915If this is true, the attribute's value will be stored as a weak
916reference.
917
918=item * auto_deref => $bool
919
920If this is true, then the reader will dereference the value when it is
921called. The attribute must have a type constraint which defines the
922attribute as an array or hash reference.
923
924=item * lazy_build => $bool
925
926Setting this to true makes the attribute lazy and provides a number of
927default methods.
928
929 has 'size' => (
930 is => 'ro',
931 lazy_build => 1,
932 );
933
934is equivalent to this:
935
936 has 'size' => (
937 is => 'ro',
938 lazy => 1,
939 builder => '_build_size',
940 clearer => 'clear_size',
941 predicate => 'has_size',
942 );
943
944=item * documentation
945
946An arbitrary string that can be retrieved later by calling C<<
947$attr->documentation >>.
948
949=back
950
951=item B<< $attr->clone(%options) >>
952
953This creates a new attribute based on attribute being cloned. You must
954supply a C<name> option to provide a new name for the attribute.
955
956The C<%options> can only specify options handled by
957L<Class::MOP::Attribute>.
958
36741534 959=back
960
93a708fd 961=head2 Value management
962
36741534 963=over 4
964
93a708fd 965=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
966
967This method is used internally to initialize the attribute's slot in
968the object C<$instance>.
969
970This overrides the L<Class::MOP::Attribute> method to handle lazy
971attributes, weak references, and type constraints.
bd1226e2 972
946289d1 973=item B<get_value>
974
975=item B<set_value>
976
6549b0d1 977 eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
bcbaa845 978 if($@) {
979 print "Oops: $@\n";
980 }
981
6549b0d1 982I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
bcbaa845 983
984Before setting the value, a check is made on the type constraint of
985the attribute, if it has one, to see if the value passes it. If the
cec39889 986value fails to pass, the set operation dies with a L</throw_error>.
bcbaa845 987
988Any coercion to convert values is done before checking the type constraint.
989
990To check a value against a type constraint before setting it, fetch the
ec00fa75 991attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
bcbaa845 992fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
e606ae5f 993and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
bcbaa845 994for an example.
995
a15dff8d 996=back
997
93a708fd 998=head2 Attribute Accessor generation
6ba6d68c 999
a15dff8d 1000=over 4
1001
93a708fd 1002=item B<< $attr->install_accessors >>
be05faea 1003
93a708fd 1004This method overrides the parent to also install delegation methods.
be05faea 1005
7a582117 1006If, after installing all methods, the attribute object has no associated
1007methods, it throws an error unless C<< is => 'bare' >> was passed to the
1008attribute constructor. (Trying to add an attribute that has no associated
1009methods is almost always an error.)
1010
36741534 1011=item B<< $attr->remove_accessors >>
d5c30e52 1012
93a708fd 1013This method overrides the parent to also remove delegation methods.
d5c30e52 1014
e06951bb 1015=item B<< $attr->inline_set($instance_var, $value_var) >>
d67398ab 1016
e06951bb 1017This method return a code snippet suitable for inlining the relevant
1018operation. It expect strings containing variable names to be used in the
1019inlining, like C<'$self'> or C<'$_[1]'>.
d67398ab 1020
93a708fd 1021=item B<< $attr->install_delegation >>
1022
1023This method adds its delegation methods to the attribute's associated
1024class, if it has any to add.
1025
1026=item B<< $attr->remove_delegation >>
1027
1028This method remove its delegation methods from the attribute's
1029associated class.
d5c30e52 1030
93a708fd 1031=item B<< $attr->accessor_metaclass >>
9e93dd19 1032
93a708fd 1033Returns the accessor metaclass name, which defaults to
1034L<Moose::Meta::Method::Accessor>.
1035
1036=item B<< $attr->delegation_metaclass >>
1037
1038Returns the delegation metaclass name, which defaults to
1039L<Moose::Meta::Method::Delegation>.
1040
1041=back
1042
1043=head2 Additional Moose features
1044
1045These methods are not found in the superclass. They support features
1046provided by Moose.
1047
36741534 1048=over 4
1049
93a708fd 1050=item B<< $attr->does($role) >>
1051
1052This indicates whether the I<attribute itself> does the given
36741534 1053role. The role can be given as a full class name, or as a resolvable
93a708fd 1054trait name.
1055
1056Note that this checks the attribute itself, not its type constraint,
1057so it is checking the attribute's metaclass and any traits applied to
1058the attribute.
1059
1060=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1061
1062This is an alternate constructor that handles the C<metaclass> and
1063C<traits> options.
9e93dd19 1064
93a708fd 1065Effectively, this method is a factory that finds or creates the
36741534 1066appropriate class for the given C<metaclass> and/or C<traits>.
e606ae5f 1067
93a708fd 1068Once it has the appropriate class, it will call C<< $class->new($name,
1069%options) >> on that class.
e606ae5f 1070
93a708fd 1071=item B<< $attr->clone_and_inherit_options(%options) >>
a15dff8d 1072
93a708fd 1073This method supports the C<has '+foo'> feature. It does various bits
1074of processing on the supplied C<%options> before ultimately calling
1075the C<clone> method.
6ba6d68c 1076
93a708fd 1077One of its main tasks is to make sure that the C<%options> provided
7782e1da 1078does not include the options returned by the
1079C<illegal_options_for_inheritance> method.
a15dff8d 1080
7782e1da 1081=item B<< $attr->illegal_options_for_inheritance >>
a15dff8d 1082
7782e1da 1083This returns a blacklist of options that can not be overridden in a
93a708fd 1084subclass's attribute definition.
2b86e02b 1085
93a708fd 1086This exists to allow a custom metaclass to change or add to the list
7782e1da 1087of options which can not be changed.
2b86e02b 1088
93a708fd 1089=item B<< $attr->type_constraint >>
452bac1b 1090
93a708fd 1091Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1092if it has one.
452bac1b 1093
93a708fd 1094=item B<< $attr->has_type_constraint >>
452bac1b 1095
93a708fd 1096Returns true if this attribute has a type constraint.
452bac1b 1097
93a708fd 1098=item B<< $attr->verify_against_type_constraint($value) >>
a15dff8d 1099
93a708fd 1100Given a value, this method returns true if the value is valid for the
1101attribute's type constraint. If the value is not valid, it throws an
1102error.
4b598ea3 1103
93a708fd 1104=item B<< $attr->handles >>
ca01a97b 1105
93a708fd 1106This returns the value of the C<handles> option passed to the
1107constructor.
ca01a97b 1108
93a708fd 1109=item B<< $attr->has_handles >>
ca01a97b 1110
93a708fd 1111Returns true if this attribute performs delegation.
ca01a97b 1112
93a708fd 1113=item B<< $attr->is_weak_ref >>
26fbace8 1114
93a708fd 1115Returns true if this attribute stores its value as a weak reference.
26fbace8 1116
93a708fd 1117=item B<< $attr->is_required >>
26fbace8 1118
93a708fd 1119Returns true if this attribute is required to have a value.
26fbace8 1120
93a708fd 1121=item B<< $attr->is_lazy >>
58f85113 1122
93a708fd 1123Returns true if this attribute is lazy.
26fbace8 1124
93a708fd 1125=item B<< $attr->is_lazy_build >>
ca01a97b 1126
93a708fd 1127Returns true if the C<lazy_build> option was true when passed to the
1128constructor.
4b598ea3 1129
93a708fd 1130=item B<< $attr->should_coerce >>
6ba6d68c 1131
93a708fd 1132Returns true if the C<coerce> option passed to the constructor was
1133true.
536f0b17 1134
93a708fd 1135=item B<< $attr->should_auto_deref >>
536f0b17 1136
93a708fd 1137Returns true if the C<auto_deref> option passed to the constructor was
1138true.
536f0b17 1139
93a708fd 1140=item B<< $attr->trigger >>
8c9d74e7 1141
93a708fd 1142This is the subroutine reference that was in the C<trigger> option
1143passed to the constructor, if any.
02a0fb52 1144
36741534 1145=item B<< $attr->has_trigger >>
8c9d74e7 1146
93a708fd 1147Returns true if this attribute has a trigger set.
02a0fb52 1148
93a708fd 1149=item B<< $attr->documentation >>
ddbdc0cb 1150
93a708fd 1151Returns the value that was in the C<documentation> option passed to
1152the constructor, if any.
ddbdc0cb 1153
93a708fd 1154=item B<< $attr->has_documentation >>
ddbdc0cb 1155
93a708fd 1156Returns true if this attribute has any documentation.
ddbdc0cb 1157
93a708fd 1158=item B<< $attr->applied_traits >>
88f23977 1159
93a708fd 1160This returns an array reference of all the traits which were applied
1161to this attribute. If none were applied, this returns C<undef>.
88f23977 1162
93a708fd 1163=item B<< $attr->has_applied_traits >>
88f23977 1164
93a708fd 1165Returns true if this attribute has any traits applied.
88f23977 1166
c0e30cf5 1167=back
1168
1169=head1 BUGS
1170
d4048ef3 1171See L<Moose/BUGS> for details on reporting bugs.
c0e30cf5 1172
c0e30cf5 1173=head1 AUTHOR
1174
1175Stevan Little E<lt>stevan@iinteractive.comE<gt>
1176
98aae381 1177Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1178
c0e30cf5 1179=head1 COPYRIGHT AND LICENSE
1180
7e0492d3 1181Copyright 2006-2010 by Infinity Interactive, Inc.
c0e30cf5 1182
1183L<http://www.iinteractive.com>
1184
1185This library is free software; you can redistribute it and/or modify
26fbace8 1186it under the same terms as Perl itself.
c0e30cf5 1187
8a7a9c53 1188=cut