bump version to 1.15
[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
efa728b4 12our $VERSION = '1.15';
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 { $_ => $_ }
ba7d613d 688 map { $_->name }
689 grep { !$_->isa('Class::MOP::Method::Meta') } (
690 $role_meta->_get_local_methods,
691 $role_meta->get_required_method_list,
c7761602 692 );
452bac1b 693}
694
695sub _find_delegate_metaclass {
696 my $self = shift;
98aae381 697 if (my $class = $self->_isa_metadata) {
9031e2c4 698 # we might be dealing with a non-Moose class,
699 # and need to make our own metaclass. if there's
700 # already a metaclass, it will be returned
88389e14 701 return Class::MOP::Class->initialize($class);
452bac1b 702 }
98aae381 703 elsif (my $role = $self->_does_metadata) {
91e6653b 704 return Class::MOP::class_of($role);
452bac1b 705 }
706 else {
be05faea 707 $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
452bac1b 708 }
709}
710
711sub _get_delegate_method_list {
712 my $self = shift;
713 my $meta = $self->_find_delegate_metaclass;
714 if ($meta->isa('Class::MOP::Class')) {
e606ae5f 715 return map { $_->name } # NOTE: !never! delegate &meta
ba7d613d 716 grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
e606ae5f 717 $meta->get_all_methods;
452bac1b 718 }
719 elsif ($meta->isa('Moose::Meta::Role')) {
26fbace8 720 return $meta->get_method_list;
452bac1b 721 }
722 else {
be05faea 723 $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
452bac1b 724 }
725}
726
bd1226e2 727sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
728
a05f85c1 729sub _make_delegation_method {
46f7e6a5 730 my ( $self, $handle_name, $method_to_call ) = @_;
a05f85c1 731
3c573ca4 732 my @curried_arguments;
2de18801 733
3c573ca4 734 ($method_to_call, @curried_arguments) = @$method_to_call
2de18801 735 if 'ARRAY' eq ref($method_to_call);
736
bd1226e2 737 return $self->delegation_metaclass->new(
46f7e6a5 738 name => $handle_name,
739 package_name => $self->associated_class->name,
740 attribute => $self,
741 delegate_to_method => $method_to_call,
3c573ca4 742 curried_arguments => \@curried_arguments,
a05f85c1 743 );
744}
745
9c9563c7 746sub _coerce_and_verify {
747 my $self = shift;
748 my $val = shift;
749 my $instance = shift;
750
751 return $val unless $self->has_type_constraint;
752
2b54d2a6 753 $val = $self->type_constraint->coerce($val)
5aab256d 754 if $self->should_coerce && $self->type_constraint->has_coercion;
9c9563c7 755
756 $self->verify_against_type_constraint($val, instance => $instance);
757
758 return $val;
759}
760
5755a9b2 761sub verify_against_type_constraint {
2b86e02b 762 my $self = shift;
763 my $val = shift;
764
765 return 1 if !$self->has_type_constraint;
766
767 my $type_constraint = $self->type_constraint;
768
769 $type_constraint->check($val)
770 || $self->throw_error("Attribute ("
771 . $self->name
772 . ") does not pass the type constraint because: "
773 . $type_constraint->get_message($val), data => $val, @_);
774}
775
21f1e231 776package Moose::Meta::Attribute::Custom::Moose;
777sub register_implementation { 'Moose::Meta::Attribute' }
778
c0e30cf5 7791;
780
781__END__
782
783=pod
784
785=head1 NAME
786
6ba6d68c 787Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5 788
789=head1 DESCRIPTION
790
93a708fd 791This class is a subclass of L<Class::MOP::Attribute> that provides
792additional Moose-specific functionality.
6ba6d68c 793
7854b409 794To really understand this class, you will need to start with the
795L<Class::MOP::Attribute> documentation. This class can be understood
796as a set of additional features on top of the basic feature provided
797by that parent class.
e522431d 798
d4b1449e 799=head1 INHERITANCE
800
801C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
802
c0e30cf5 803=head1 METHODS
804
93a708fd 805Many of the documented below override methods in
806L<Class::MOP::Attribute> and add Moose specific features.
6ba6d68c 807
93a708fd 808=head2 Creation
6ba6d68c 809
c0e30cf5 810=over 4
811
93a708fd 812=item B<< Moose::Meta::Attribute->new(%options) >>
c0e30cf5 813
93a708fd 814This method overrides the L<Class::MOP::Attribute> constructor.
c32c2c61 815
93a708fd 816Many of the options below are described in more detail in the
817L<Moose::Manual::Attributes> document.
6e2840b7 818
93a708fd 819It adds the following options to the constructor:
d500266f 820
93a708fd 821=over 8
452bac1b 822
996b8c8d 823=item * is => 'ro', 'rw', 'bare'
e1d6f0a3 824
93a708fd 825This provides a shorthand for specifying the C<reader>, C<writer>, or
826C<accessor> names. If the attribute is read-only ('ro') then it will
827have a C<reader> method with the same attribute as the name.
e606ae5f 828
93a708fd 829If it is read-write ('rw') then it will have an C<accessor> method
830with the same name. If you provide an explicit C<writer> for a
831read-write attribute, then you will have a C<reader> with the same
832name as the attribute, and a C<writer> with the name you provided.
e1d6f0a3 833
996b8c8d 834Use 'bare' when you are deliberately not installing any methods
835(accessor, reader, etc.) associated with this attribute; otherwise,
836Moose will issue a deprecation warning when this attribute is added to a
9340e346 837metaclass.
996b8c8d 838
93a708fd 839=item * isa => $type
39b3bc94 840
93a708fd 841This option accepts a type. The type can be a string, which should be
842a type name. If the type name is unknown, it is assumed to be a class
843name.
844
845This option can also accept a L<Moose::Meta::TypeConstraint> object.
846
847If you I<also> provide a C<does> option, then your C<isa> option must
848be a class name, and that class must do the role specified with
849C<does>.
850
851=item * does => $role
852
853This is short-hand for saying that the attribute's type must be an
854object which does the named role.
855
856=item * coerce => $bool
857
858This option is only valid for objects with a type constraint
3b98ba07 859(C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
93a708fd 860this attribute is set.
861
862You can make both this and the C<weak_ref> option true.
863
864=item * trigger => $sub
865
866This option accepts a subroutine reference, which will be called after
867the attribute is set.
868
869=item * required => $bool
870
871An attribute which is required must be provided to the constructor. An
872attribute which is required can also have a C<default> or C<builder>,
36741534 873which will satisfy its required-ness.
93a708fd 874
875A required attribute must have a C<default>, C<builder> or a
876non-C<undef> C<init_arg>
877
878=item * lazy => $bool
879
880A lazy attribute must have a C<default> or C<builder>. When an
881attribute is lazy, the default value will not be calculated until the
882attribute is read.
883
884=item * weak_ref => $bool
885
886If this is true, the attribute's value will be stored as a weak
887reference.
888
889=item * auto_deref => $bool
890
891If this is true, then the reader will dereference the value when it is
892called. The attribute must have a type constraint which defines the
893attribute as an array or hash reference.
894
895=item * lazy_build => $bool
896
897Setting this to true makes the attribute lazy and provides a number of
898default methods.
899
900 has 'size' => (
901 is => 'ro',
902 lazy_build => 1,
903 );
904
905is equivalent to this:
906
907 has 'size' => (
908 is => 'ro',
909 lazy => 1,
910 builder => '_build_size',
911 clearer => 'clear_size',
912 predicate => 'has_size',
913 );
914
915=item * documentation
916
917An arbitrary string that can be retrieved later by calling C<<
918$attr->documentation >>.
919
920=back
921
922=item B<< $attr->clone(%options) >>
923
924This creates a new attribute based on attribute being cloned. You must
925supply a C<name> option to provide a new name for the attribute.
926
927The C<%options> can only specify options handled by
928L<Class::MOP::Attribute>.
929
36741534 930=back
931
93a708fd 932=head2 Value management
933
36741534 934=over 4
935
93a708fd 936=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
937
938This method is used internally to initialize the attribute's slot in
939the object C<$instance>.
940
941This overrides the L<Class::MOP::Attribute> method to handle lazy
942attributes, weak references, and type constraints.
bd1226e2 943
946289d1 944=item B<get_value>
945
946=item B<set_value>
947
6549b0d1 948 eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
bcbaa845 949 if($@) {
950 print "Oops: $@\n";
951 }
952
6549b0d1 953I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
bcbaa845 954
955Before setting the value, a check is made on the type constraint of
956the attribute, if it has one, to see if the value passes it. If the
cec39889 957value fails to pass, the set operation dies with a L</throw_error>.
bcbaa845 958
959Any coercion to convert values is done before checking the type constraint.
960
961To check a value against a type constraint before setting it, fetch the
ec00fa75 962attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
bcbaa845 963fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
e606ae5f 964and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
bcbaa845 965for an example.
966
a15dff8d 967=back
968
93a708fd 969=head2 Attribute Accessor generation
6ba6d68c 970
a15dff8d 971=over 4
972
93a708fd 973=item B<< $attr->install_accessors >>
be05faea 974
93a708fd 975This method overrides the parent to also install delegation methods.
be05faea 976
7a582117 977If, after installing all methods, the attribute object has no associated
978methods, it throws an error unless C<< is => 'bare' >> was passed to the
979attribute constructor. (Trying to add an attribute that has no associated
980methods is almost always an error.)
981
36741534 982=item B<< $attr->remove_accessors >>
d5c30e52 983
93a708fd 984This method overrides the parent to also remove delegation methods.
d5c30e52 985
e06951bb 986=item B<< $attr->inline_set($instance_var, $value_var) >>
d67398ab 987
e06951bb 988This method return a code snippet suitable for inlining the relevant
989operation. It expect strings containing variable names to be used in the
990inlining, like C<'$self'> or C<'$_[1]'>.
d67398ab 991
93a708fd 992=item B<< $attr->install_delegation >>
993
994This method adds its delegation methods to the attribute's associated
995class, if it has any to add.
996
997=item B<< $attr->remove_delegation >>
998
999This method remove its delegation methods from the attribute's
1000associated class.
d5c30e52 1001
93a708fd 1002=item B<< $attr->accessor_metaclass >>
9e93dd19 1003
93a708fd 1004Returns the accessor metaclass name, which defaults to
1005L<Moose::Meta::Method::Accessor>.
1006
1007=item B<< $attr->delegation_metaclass >>
1008
1009Returns the delegation metaclass name, which defaults to
1010L<Moose::Meta::Method::Delegation>.
1011
1012=back
1013
1014=head2 Additional Moose features
1015
1016These methods are not found in the superclass. They support features
1017provided by Moose.
1018
36741534 1019=over 4
1020
93a708fd 1021=item B<< $attr->does($role) >>
1022
1023This indicates whether the I<attribute itself> does the given
36741534 1024role. The role can be given as a full class name, or as a resolvable
93a708fd 1025trait name.
1026
1027Note that this checks the attribute itself, not its type constraint,
1028so it is checking the attribute's metaclass and any traits applied to
1029the attribute.
1030
1031=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1032
1033This is an alternate constructor that handles the C<metaclass> and
1034C<traits> options.
9e93dd19 1035
93a708fd 1036Effectively, this method is a factory that finds or creates the
36741534 1037appropriate class for the given C<metaclass> and/or C<traits>.
e606ae5f 1038
93a708fd 1039Once it has the appropriate class, it will call C<< $class->new($name,
1040%options) >> on that class.
e606ae5f 1041
93a708fd 1042=item B<< $attr->clone_and_inherit_options(%options) >>
a15dff8d 1043
93a708fd 1044This method supports the C<has '+foo'> feature. It does various bits
1045of processing on the supplied C<%options> before ultimately calling
1046the C<clone> method.
6ba6d68c 1047
93a708fd 1048One of its main tasks is to make sure that the C<%options> provided
7782e1da 1049does not include the options returned by the
1050C<illegal_options_for_inheritance> method.
a15dff8d 1051
7782e1da 1052=item B<< $attr->illegal_options_for_inheritance >>
a15dff8d 1053
7782e1da 1054This returns a blacklist of options that can not be overridden in a
93a708fd 1055subclass's attribute definition.
2b86e02b 1056
93a708fd 1057This exists to allow a custom metaclass to change or add to the list
7782e1da 1058of options which can not be changed.
2b86e02b 1059
93a708fd 1060=item B<< $attr->type_constraint >>
452bac1b 1061
93a708fd 1062Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1063if it has one.
452bac1b 1064
93a708fd 1065=item B<< $attr->has_type_constraint >>
452bac1b 1066
93a708fd 1067Returns true if this attribute has a type constraint.
452bac1b 1068
93a708fd 1069=item B<< $attr->verify_against_type_constraint($value) >>
a15dff8d 1070
93a708fd 1071Given a value, this method returns true if the value is valid for the
1072attribute's type constraint. If the value is not valid, it throws an
1073error.
4b598ea3 1074
93a708fd 1075=item B<< $attr->handles >>
ca01a97b 1076
93a708fd 1077This returns the value of the C<handles> option passed to the
1078constructor.
ca01a97b 1079
93a708fd 1080=item B<< $attr->has_handles >>
ca01a97b 1081
93a708fd 1082Returns true if this attribute performs delegation.
ca01a97b 1083
93a708fd 1084=item B<< $attr->is_weak_ref >>
26fbace8 1085
93a708fd 1086Returns true if this attribute stores its value as a weak reference.
26fbace8 1087
93a708fd 1088=item B<< $attr->is_required >>
26fbace8 1089
93a708fd 1090Returns true if this attribute is required to have a value.
26fbace8 1091
93a708fd 1092=item B<< $attr->is_lazy >>
58f85113 1093
93a708fd 1094Returns true if this attribute is lazy.
26fbace8 1095
93a708fd 1096=item B<< $attr->is_lazy_build >>
ca01a97b 1097
93a708fd 1098Returns true if the C<lazy_build> option was true when passed to the
1099constructor.
4b598ea3 1100
93a708fd 1101=item B<< $attr->should_coerce >>
6ba6d68c 1102
93a708fd 1103Returns true if the C<coerce> option passed to the constructor was
1104true.
536f0b17 1105
93a708fd 1106=item B<< $attr->should_auto_deref >>
536f0b17 1107
93a708fd 1108Returns true if the C<auto_deref> option passed to the constructor was
1109true.
536f0b17 1110
93a708fd 1111=item B<< $attr->trigger >>
8c9d74e7 1112
93a708fd 1113This is the subroutine reference that was in the C<trigger> option
1114passed to the constructor, if any.
02a0fb52 1115
36741534 1116=item B<< $attr->has_trigger >>
8c9d74e7 1117
93a708fd 1118Returns true if this attribute has a trigger set.
02a0fb52 1119
93a708fd 1120=item B<< $attr->documentation >>
ddbdc0cb 1121
93a708fd 1122Returns the value that was in the C<documentation> option passed to
1123the constructor, if any.
ddbdc0cb 1124
93a708fd 1125=item B<< $attr->has_documentation >>
ddbdc0cb 1126
93a708fd 1127Returns true if this attribute has any documentation.
ddbdc0cb 1128
93a708fd 1129=item B<< $attr->applied_traits >>
88f23977 1130
93a708fd 1131This returns an array reference of all the traits which were applied
1132to this attribute. If none were applied, this returns C<undef>.
88f23977 1133
93a708fd 1134=item B<< $attr->has_applied_traits >>
88f23977 1135
93a708fd 1136Returns true if this attribute has any traits applied.
88f23977 1137
c0e30cf5 1138=back
1139
1140=head1 BUGS
1141
d4048ef3 1142See L<Moose/BUGS> for details on reporting bugs.
c0e30cf5 1143
c0e30cf5 1144=head1 AUTHOR
1145
1146Stevan Little E<lt>stevan@iinteractive.comE<gt>
1147
98aae381 1148Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1149
c0e30cf5 1150=head1 COPYRIGHT AND LICENSE
1151
7e0492d3 1152Copyright 2006-2010 by Infinity Interactive, Inc.
c0e30cf5 1153
1154L<http://www.iinteractive.com>
1155
1156This library is free software; you can redistribute it and/or modify
26fbace8 1157it under the same terms as Perl itself.
c0e30cf5 1158
8a7a9c53 1159=cut