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