Include the class name in the method-less attribute message
[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
9e4ed568 10our $VERSION = '0.84';
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(
8f4450f3 565 'Attribute (' . $self->name . ') of class '
566 . $self->associated_class->name
567 . ' has no associated methods'
86cf196b 568 . ' (did you mean to provide an "is" argument?)'
569 . "\n"
570 )
571 }
e606ae5f 572 return;
573}
26fbace8 574
3b6e2290 575sub _process_accessors {
576 my $self = shift;
577 my ($type, $accessor, $generate_as_inline_methods) = @_;
578 $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH';
99541dfd 579 my $method = $self->associated_class->get_method($accessor);
580 if ($method && !$method->isa('Class::MOP::Method::Accessor')
581 && (!$self->definition_context
582 || $method->package_name eq $self->definition_context->{package})) {
3b6e2290 583 Carp::cluck(
584 "You cannot overwrite a locally defined method ($accessor) with "
585 . "an accessor"
586 );
587 }
588 $self->SUPER::_process_accessors(@_);
589}
590
e1d6f0a3 591sub remove_accessors {
592 my $self = shift;
593 $self->SUPER::remove_accessors(@_);
594 $self->remove_delegation if $self->has_handles;
595 return;
596}
597
e606ae5f 598sub install_delegation {
599 my $self = shift;
26fbace8 600
e606ae5f 601 # NOTE:
602 # Here we canonicalize the 'handles' option
603 # this will sort out any details and always
604 # return an hash of methods which we want
605 # to delagate to, see that method for details
606 my %handles = $self->_canonicalize_handles;
607
e606ae5f 608
609 # install the delegation ...
610 my $associated_class = $self->associated_class;
611 foreach my $handle (keys %handles) {
612 my $method_to_call = $handles{$handle};
613 my $class_name = $associated_class->name;
614 my $name = "${class_name}::${handle}";
26fbace8 615
452bac1b 616 (!$associated_class->has_method($handle))
cee532a1 617 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
26fbace8 618
e606ae5f 619 # NOTE:
620 # handles is not allowed to delegate
621 # any of these methods, as they will
622 # override the ones in your class, which
623 # is almost certainly not what you want.
4fe78472 624
e606ae5f 625 # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
626 #cluck("Not delegating method '$handle' because it is a core method") and
627 next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
26fbace8 628
46f7e6a5 629 my $method = $self->_make_delegation_method($handle, $method_to_call);
a05f85c1 630
631 $self->associated_class->add_method($method->name, $method);
0bbd378f 632 $self->associate_method($method);
d03bd989 633 }
452bac1b 634}
635
e1d6f0a3 636sub remove_delegation {
637 my $self = shift;
638 my %handles = $self->_canonicalize_handles;
639 my $associated_class = $self->associated_class;
640 foreach my $handle (keys %handles) {
641 $self->associated_class->remove_method($handle);
642 }
643}
644
98aae381 645# private methods to help delegation ...
646
452bac1b 647sub _canonicalize_handles {
648 my $self = shift;
649 my $handles = $self->handles;
c84f324f 650 if (my $handle_type = ref($handles)) {
651 if ($handle_type eq 'HASH') {
652 return %{$handles};
653 }
654 elsif ($handle_type eq 'ARRAY') {
655 return map { $_ => $_ } @{$handles};
656 }
657 elsif ($handle_type eq 'Regexp') {
658 ($self->has_type_constraint)
0286711b 659 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
26fbace8 660 return map { ($_ => $_) }
c84f324f 661 grep { /$handles/ } $self->_get_delegate_method_list;
662 }
663 elsif ($handle_type eq 'CODE') {
664 return $handles->($self, $self->_find_delegate_metaclass);
665 }
6cbf4a23 666 elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
667 return map { $_ => $_ } @{ $handles->methods };
668 }
c84f324f 669 else {
be05faea 670 $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
c84f324f 671 }
452bac1b 672 }
673 else {
c8d9f1e2 674 Class::MOP::load_class($handles);
675 my $role_meta = Class::MOP::class_of($handles);
c84f324f 676
677 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
425ca605 678 || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
d03bd989 679
c84f324f 680 return map { $_ => $_ } (
26fbace8 681 $role_meta->get_method_list,
b07a4e6d 682 map { $_->name } $role_meta->get_required_method_list,
c84f324f 683 );
452bac1b 684 }
685}
686
687sub _find_delegate_metaclass {
688 my $self = shift;
98aae381 689 if (my $class = $self->_isa_metadata) {
9031e2c4 690 # we might be dealing with a non-Moose class,
691 # and need to make our own metaclass. if there's
692 # already a metaclass, it will be returned
452bac1b 693 return Moose::Meta::Class->initialize($class);
694 }
98aae381 695 elsif (my $role = $self->_does_metadata) {
91e6653b 696 return Class::MOP::class_of($role);
452bac1b 697 }
698 else {
be05faea 699 $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
452bac1b 700 }
701}
702
703sub _get_delegate_method_list {
704 my $self = shift;
705 my $meta = $self->_find_delegate_metaclass;
706 if ($meta->isa('Class::MOP::Class')) {
e606ae5f 707 return map { $_->name } # NOTE: !never! delegate &meta
708 grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
709 $meta->get_all_methods;
452bac1b 710 }
711 elsif ($meta->isa('Moose::Meta::Role')) {
26fbace8 712 return $meta->get_method_list;
452bac1b 713 }
714 else {
be05faea 715 $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
452bac1b 716 }
717}
718
bd1226e2 719sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
720
a05f85c1 721sub _make_delegation_method {
46f7e6a5 722 my ( $self, $handle_name, $method_to_call ) = @_;
a05f85c1 723
724 my $method_body;
725
46f7e6a5 726 $method_body = $method_to_call
727 if 'CODE' eq ref($method_to_call);
a05f85c1 728
bd1226e2 729 return $self->delegation_metaclass->new(
46f7e6a5 730 name => $handle_name,
731 package_name => $self->associated_class->name,
732 attribute => $self,
733 delegate_to_method => $method_to_call,
a05f85c1 734 );
735}
736
9c9563c7 737sub _coerce_and_verify {
738 my $self = shift;
739 my $val = shift;
740 my $instance = shift;
741
742 return $val unless $self->has_type_constraint;
743
744 my $type_constraint = $self->type_constraint;
745 if ($self->should_coerce && $type_constraint->has_coercion) {
746 $val = $type_constraint->coerce($val);
747 }
748
749 $self->verify_against_type_constraint($val, instance => $instance);
750
751 return $val;
752}
753
5755a9b2 754sub verify_against_type_constraint {
2b86e02b 755 my $self = shift;
756 my $val = shift;
757
758 return 1 if !$self->has_type_constraint;
759
760 my $type_constraint = $self->type_constraint;
761
762 $type_constraint->check($val)
763 || $self->throw_error("Attribute ("
764 . $self->name
765 . ") does not pass the type constraint because: "
766 . $type_constraint->get_message($val), data => $val, @_);
767}
768
21f1e231 769package Moose::Meta::Attribute::Custom::Moose;
770sub register_implementation { 'Moose::Meta::Attribute' }
771
c0e30cf5 7721;
773
774__END__
775
776=pod
777
778=head1 NAME
779
6ba6d68c 780Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5 781
782=head1 DESCRIPTION
783
93a708fd 784This class is a subclass of L<Class::MOP::Attribute> that provides
785additional Moose-specific functionality.
6ba6d68c 786
7854b409 787To really understand this class, you will need to start with the
788L<Class::MOP::Attribute> documentation. This class can be understood
789as a set of additional features on top of the basic feature provided
790by that parent class.
e522431d 791
d4b1449e 792=head1 INHERITANCE
793
794C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
795
c0e30cf5 796=head1 METHODS
797
93a708fd 798Many of the documented below override methods in
799L<Class::MOP::Attribute> and add Moose specific features.
6ba6d68c 800
93a708fd 801=head2 Creation
6ba6d68c 802
c0e30cf5 803=over 4
804
93a708fd 805=item B<< Moose::Meta::Attribute->new(%options) >>
c0e30cf5 806
93a708fd 807This method overrides the L<Class::MOP::Attribute> constructor.
c32c2c61 808
93a708fd 809Many of the options below are described in more detail in the
810L<Moose::Manual::Attributes> document.
6e2840b7 811
93a708fd 812It adds the following options to the constructor:
d500266f 813
93a708fd 814=over 8
452bac1b 815
996b8c8d 816=item * is => 'ro', 'rw', 'bare'
e1d6f0a3 817
93a708fd 818This provides a shorthand for specifying the C<reader>, C<writer>, or
819C<accessor> names. If the attribute is read-only ('ro') then it will
820have a C<reader> method with the same attribute as the name.
e606ae5f 821
93a708fd 822If it is read-write ('rw') then it will have an C<accessor> method
823with the same name. If you provide an explicit C<writer> for a
824read-write attribute, then you will have a C<reader> with the same
825name as the attribute, and a C<writer> with the name you provided.
e1d6f0a3 826
996b8c8d 827Use 'bare' when you are deliberately not installing any methods
828(accessor, reader, etc.) associated with this attribute; otherwise,
829Moose will issue a deprecation warning when this attribute is added to a
830metaclass.
831
93a708fd 832=item * isa => $type
39b3bc94 833
93a708fd 834This option accepts a type. The type can be a string, which should be
835a type name. If the type name is unknown, it is assumed to be a class
836name.
837
838This option can also accept a L<Moose::Meta::TypeConstraint> object.
839
840If you I<also> provide a C<does> option, then your C<isa> option must
841be a class name, and that class must do the role specified with
842C<does>.
843
844=item * does => $role
845
846This is short-hand for saying that the attribute's type must be an
847object which does the named role.
848
849=item * coerce => $bool
850
851This option is only valid for objects with a type constraint
852(C<isa>). If this is true, then coercions will be applied whenever
853this attribute is set.
854
855You can make both this and the C<weak_ref> option true.
856
857=item * trigger => $sub
858
859This option accepts a subroutine reference, which will be called after
860the attribute is set.
861
862=item * required => $bool
863
864An attribute which is required must be provided to the constructor. An
865attribute which is required can also have a C<default> or C<builder>,
36741534 866which will satisfy its required-ness.
93a708fd 867
868A required attribute must have a C<default>, C<builder> or a
869non-C<undef> C<init_arg>
870
871=item * lazy => $bool
872
873A lazy attribute must have a C<default> or C<builder>. When an
874attribute is lazy, the default value will not be calculated until the
875attribute is read.
876
877=item * weak_ref => $bool
878
879If this is true, the attribute's value will be stored as a weak
880reference.
881
882=item * auto_deref => $bool
883
884If this is true, then the reader will dereference the value when it is
885called. The attribute must have a type constraint which defines the
886attribute as an array or hash reference.
887
888=item * lazy_build => $bool
889
890Setting this to true makes the attribute lazy and provides a number of
891default methods.
892
893 has 'size' => (
894 is => 'ro',
895 lazy_build => 1,
896 );
897
898is equivalent to this:
899
900 has 'size' => (
901 is => 'ro',
902 lazy => 1,
903 builder => '_build_size',
904 clearer => 'clear_size',
905 predicate => 'has_size',
906 );
907
908=item * documentation
909
910An arbitrary string that can be retrieved later by calling C<<
911$attr->documentation >>.
912
913=back
914
915=item B<< $attr->clone(%options) >>
916
917This creates a new attribute based on attribute being cloned. You must
918supply a C<name> option to provide a new name for the attribute.
919
920The C<%options> can only specify options handled by
921L<Class::MOP::Attribute>.
922
36741534 923=back
924
93a708fd 925=head2 Value management
926
36741534 927=over 4
928
93a708fd 929=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
930
931This method is used internally to initialize the attribute's slot in
932the object C<$instance>.
933
934This overrides the L<Class::MOP::Attribute> method to handle lazy
935attributes, weak references, and type constraints.
bd1226e2 936
946289d1 937=item B<get_value>
938
939=item B<set_value>
940
6549b0d1 941 eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
bcbaa845 942 if($@) {
943 print "Oops: $@\n";
944 }
945
6549b0d1 946I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
bcbaa845 947
948Before setting the value, a check is made on the type constraint of
949the attribute, if it has one, to see if the value passes it. If the
46cb090f 950value fails to pass, the set operation dies with a L<throw_error>.
bcbaa845 951
952Any coercion to convert values is done before checking the type constraint.
953
954To check a value against a type constraint before setting it, fetch the
ec00fa75 955attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
bcbaa845 956fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
e606ae5f 957and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
bcbaa845 958for an example.
959
a15dff8d 960=back
961
93a708fd 962=head2 Attribute Accessor generation
6ba6d68c 963
a15dff8d 964=over 4
965
93a708fd 966=item B<< $attr->install_accessors >>
be05faea 967
93a708fd 968This method overrides the parent to also install delegation methods.
be05faea 969
7a582117 970If, after installing all methods, the attribute object has no associated
971methods, it throws an error unless C<< is => 'bare' >> was passed to the
972attribute constructor. (Trying to add an attribute that has no associated
973methods is almost always an error.)
974
36741534 975=item B<< $attr->remove_accessors >>
d5c30e52 976
93a708fd 977This method overrides the parent to also remove delegation methods.
d5c30e52 978
93a708fd 979=item B<< $attr->install_delegation >>
980
981This method adds its delegation methods to the attribute's associated
982class, if it has any to add.
983
984=item B<< $attr->remove_delegation >>
985
986This method remove its delegation methods from the attribute's
987associated class.
d5c30e52 988
93a708fd 989=item B<< $attr->accessor_metaclass >>
9e93dd19 990
93a708fd 991Returns the accessor metaclass name, which defaults to
992L<Moose::Meta::Method::Accessor>.
993
994=item B<< $attr->delegation_metaclass >>
995
996Returns the delegation metaclass name, which defaults to
997L<Moose::Meta::Method::Delegation>.
998
999=back
1000
1001=head2 Additional Moose features
1002
1003These methods are not found in the superclass. They support features
1004provided by Moose.
1005
36741534 1006=over 4
1007
93a708fd 1008=item B<< $attr->does($role) >>
1009
1010This indicates whether the I<attribute itself> does the given
36741534 1011role. The role can be given as a full class name, or as a resolvable
93a708fd 1012trait name.
1013
1014Note that this checks the attribute itself, not its type constraint,
1015so it is checking the attribute's metaclass and any traits applied to
1016the attribute.
1017
1018=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1019
1020This is an alternate constructor that handles the C<metaclass> and
1021C<traits> options.
9e93dd19 1022
93a708fd 1023Effectively, this method is a factory that finds or creates the
36741534 1024appropriate class for the given C<metaclass> and/or C<traits>.
e606ae5f 1025
93a708fd 1026Once it has the appropriate class, it will call C<< $class->new($name,
1027%options) >> on that class.
e606ae5f 1028
93a708fd 1029=item B<< $attr->clone_and_inherit_options(%options) >>
a15dff8d 1030
93a708fd 1031This method supports the C<has '+foo'> feature. It does various bits
1032of processing on the supplied C<%options> before ultimately calling
1033the C<clone> method.
6ba6d68c 1034
93a708fd 1035One of its main tasks is to make sure that the C<%options> provided
1036only includes the options returned by the
1037C<legal_options_for_inheritance> method.
a15dff8d 1038
93a708fd 1039=item B<< $attr->legal_options_for_inheritance >>
a15dff8d 1040
93a708fd 1041This returns a whitelist of options that can be overridden in a
1042subclass's attribute definition.
2b86e02b 1043
93a708fd 1044This exists to allow a custom metaclass to change or add to the list
1045of options which can be changed.
2b86e02b 1046
93a708fd 1047=item B<< $attr->type_constraint >>
452bac1b 1048
93a708fd 1049Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1050if it has one.
452bac1b 1051
93a708fd 1052=item B<< $attr->has_type_constraint >>
452bac1b 1053
93a708fd 1054Returns true if this attribute has a type constraint.
452bac1b 1055
93a708fd 1056=item B<< $attr->verify_against_type_constraint($value) >>
a15dff8d 1057
93a708fd 1058Given a value, this method returns true if the value is valid for the
1059attribute's type constraint. If the value is not valid, it throws an
1060error.
4b598ea3 1061
93a708fd 1062=item B<< $attr->handles >>
ca01a97b 1063
93a708fd 1064This returns the value of the C<handles> option passed to the
1065constructor.
ca01a97b 1066
93a708fd 1067=item B<< $attr->has_handles >>
ca01a97b 1068
93a708fd 1069Returns true if this attribute performs delegation.
ca01a97b 1070
93a708fd 1071=item B<< $attr->is_weak_ref >>
26fbace8 1072
93a708fd 1073Returns true if this attribute stores its value as a weak reference.
26fbace8 1074
93a708fd 1075=item B<< $attr->is_required >>
26fbace8 1076
93a708fd 1077Returns true if this attribute is required to have a value.
26fbace8 1078
93a708fd 1079=item B<< $attr->is_lazy >>
58f85113 1080
93a708fd 1081Returns true if this attribute is lazy.
26fbace8 1082
93a708fd 1083=item B<< $attr->is_lazy_build >>
ca01a97b 1084
93a708fd 1085Returns true if the C<lazy_build> option was true when passed to the
1086constructor.
4b598ea3 1087
93a708fd 1088=item B<< $attr->should_coerce >>
6ba6d68c 1089
93a708fd 1090Returns true if the C<coerce> option passed to the constructor was
1091true.
536f0b17 1092
93a708fd 1093=item B<< $attr->should_auto_deref >>
536f0b17 1094
93a708fd 1095Returns true if the C<auto_deref> option passed to the constructor was
1096true.
536f0b17 1097
93a708fd 1098=item B<< $attr->trigger >>
8c9d74e7 1099
93a708fd 1100This is the subroutine reference that was in the C<trigger> option
1101passed to the constructor, if any.
02a0fb52 1102
36741534 1103=item B<< $attr->has_trigger >>
8c9d74e7 1104
93a708fd 1105Returns true if this attribute has a trigger set.
02a0fb52 1106
93a708fd 1107=item B<< $attr->documentation >>
ddbdc0cb 1108
93a708fd 1109Returns the value that was in the C<documentation> option passed to
1110the constructor, if any.
ddbdc0cb 1111
93a708fd 1112=item B<< $attr->has_documentation >>
ddbdc0cb 1113
93a708fd 1114Returns true if this attribute has any documentation.
ddbdc0cb 1115
93a708fd 1116=item B<< $attr->applied_traits >>
88f23977 1117
93a708fd 1118This returns an array reference of all the traits which were applied
1119to this attribute. If none were applied, this returns C<undef>.
88f23977 1120
93a708fd 1121=item B<< $attr->has_applied_traits >>
88f23977 1122
93a708fd 1123Returns true if this attribute has any traits applied.
88f23977 1124
c0e30cf5 1125=back
1126
1127=head1 BUGS
1128
26fbace8 1129All complex software has bugs lurking in it, and this module is no
c0e30cf5 1130exception. If you find a bug please either email me, or add the bug
1131to cpan-RT.
1132
c0e30cf5 1133=head1 AUTHOR
1134
1135Stevan Little E<lt>stevan@iinteractive.comE<gt>
1136
98aae381 1137Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1138
c0e30cf5 1139=head1 COPYRIGHT AND LICENSE
1140
2840a3b2 1141Copyright 2006-2009 by Infinity Interactive, Inc.
c0e30cf5 1142
1143L<http://www.iinteractive.com>
1144
1145This library is free software; you can redistribute it and/or modify
26fbace8 1146it under the same terms as Perl itself.
c0e30cf5 1147
8a7a9c53 1148=cut