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