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