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