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