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