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