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