bump version to 0.79
[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
dbe21639 10our $VERSION = '0.79';
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;
351 $options->{required} = 1;
352 $options->{builder} ||= "_build_${name}";
353 if ($name =~ /^_/) {
f3c4e20e 354 $options->{clearer} ||= "_clear${name}";
355 $options->{predicate} ||= "_has${name}";
d03bd989 356 }
a6c84c69 357 else {
f3c4e20e 358 $options->{clearer} ||= "clear_${name}";
359 $options->{predicate} ||= "has_${name}";
26fbace8 360 }
f3c4e20e 361 }
8de73ff1 362
f3c4e20e 363 if (exists $options->{lazy} && $options->{lazy}) {
9edba990 364 (exists $options->{default} || defined $options->{builder} )
be05faea 365 || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
f3c4e20e 366 }
26fbace8 367
9edba990 368 if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
be05faea 369 $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
9edba990 370 }
371
78cd1d3b 372}
c0e30cf5 373
d500266f 374sub initialize_instance_slot {
ddd0ec20 375 my ($self, $meta_instance, $instance, $params) = @_;
d500266f 376 my $init_arg = $self->init_arg();
377 # try to fetch the init arg from the %params ...
ddd0ec20 378
26fbace8 379 my $val;
1ed0b94f 380 my $value_is_set;
625d571f 381 if ( defined($init_arg) and exists $params->{$init_arg}) {
d500266f 382 $val = $params->{$init_arg};
d03bd989 383 $value_is_set = 1;
d500266f 384 }
385 else {
386 # skip it if it's lazy
387 return if $self->is_lazy;
388 # and die if it's required and doesn't have a default value
be05faea 389 $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
26fbace8 390 if $self->is_required && !$self->has_default && !$self->has_builder;
ddd0ec20 391
1ed0b94f 392 # if nothing was in the %params, we can use the
393 # attribute's default value (if it has one)
394 if ($self->has_default) {
395 $val = $self->default($instance);
396 $value_is_set = 1;
d03bd989 397 }
a6c84c69 398 elsif ($self->has_builder) {
e606ae5f 399 $val = $self->_call_builder($instance);
400 $value_is_set = 1;
a0748c37 401 }
26fbace8 402 }
403
1ed0b94f 404 return unless $value_is_set;
405
9c9563c7 406 $val = $self->_coerce_and_verify( $val, $instance );
ddd0ec20 407
759e4e8f 408 $self->set_initial_value($instance, $val);
26fbace8 409 $meta_instance->weaken_slot_value($instance, $self->name)
a6c84c69 410 if ref $val && $self->is_weak_ref;
d500266f 411}
412
e606ae5f 413sub _call_builder {
414 my ( $self, $instance ) = @_;
415
416 my $builder = $self->builder();
417
418 return $instance->$builder()
419 if $instance->can( $self->builder );
420
421 $self->throw_error( blessed($instance)
422 . " does not support builder method '"
423 . $self->builder
424 . "' for attribute '"
425 . $self->name
426 . "'",
427 object => $instance,
428 );
429}
430
d617b644 431## Slot management
9e93dd19 432
8abe9636 433# FIXME:
d03bd989 434# this duplicates too much code from
435# Class::MOP::Attribute, we need to
8abe9636 436# refactor these bits eventually.
437# - SL
438sub _set_initial_slot_value {
439 my ($self, $meta_instance, $instance, $value) = @_;
440
441 my $slot_name = $self->name;
442
443 return $meta_instance->set_slot_value($instance, $slot_name, $value)
444 unless $self->has_initializer;
445
446 my ($type_constraint, $can_coerce);
447 if ($self->has_type_constraint) {
448 $type_constraint = $self->type_constraint;
449 $can_coerce = ($self->should_coerce && $type_constraint->has_coercion);
450 }
451
452 my $callback = sub {
9c9563c7 453 my $val = $self->_coerce_and_verify( shift, $instance );;
454
8abe9636 455 $meta_instance->set_slot_value($instance, $slot_name, $val);
456 };
d03bd989 457
8abe9636 458 my $initializer = $self->initializer;
459
460 # most things will just want to set a value, so make it first arg
461 $instance->$initializer($value, $callback, $self);
462}
463
946289d1 464sub set_value {
b6af66f8 465 my ($self, $instance, @args) = @_;
466 my $value = $args[0];
26fbace8 467
946289d1 468 my $attr_name = $self->name;
26fbace8 469
b6af66f8 470 if ($self->is_required and not @args) {
be05faea 471 $self->throw_error("Attribute ($attr_name) is required", object => $instance);
946289d1 472 }
26fbace8 473
9c9563c7 474 $value = $self->_coerce_and_verify( $value, $instance );
26fbace8 475
946289d1 476 my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
477 ->get_meta_instance;
26fbace8 478
479 $meta_instance->set_slot_value($instance, $attr_name, $value);
480
946289d1 481 if (ref $value && $self->is_weak_ref) {
26fbace8 482 $meta_instance->weaken_slot_value($instance, $attr_name);
946289d1 483 }
26fbace8 484
946289d1 485 if ($self->has_trigger) {
525129a5 486 $self->trigger->($instance, $value);
946289d1 487 }
488}
489
490sub get_value {
491 my ($self, $instance) = @_;
26fbace8 492
946289d1 493 if ($self->is_lazy) {
8de73ff1 494 unless ($self->has_value($instance)) {
e606ae5f 495 my $value;
8de73ff1 496 if ($self->has_default) {
e606ae5f 497 $value = $self->default($instance);
3f11800d 498 } elsif ( $self->has_builder ) {
e606ae5f 499 $value = $self->_call_builder($instance);
500 }
9c9563c7 501
502 $value = $self->_coerce_and_verify( $value, $instance );
503
e606ae5f 504 $self->set_initial_value($instance, $value);
8de73ff1 505 }
946289d1 506 }
26fbace8 507
946289d1 508 if ($self->should_auto_deref) {
26fbace8 509
946289d1 510 my $type_constraint = $self->type_constraint;
511
512 if ($type_constraint->is_a_type_of('ArrayRef')) {
513 my $rv = $self->SUPER::get_value($instance);
514 return unless defined $rv;
515 return wantarray ? @{ $rv } : $rv;
26fbace8 516 }
946289d1 517 elsif ($type_constraint->is_a_type_of('HashRef')) {
518 my $rv = $self->SUPER::get_value($instance);
519 return unless defined $rv;
520 return wantarray ? %{ $rv } : $rv;
26fbace8 521 }
946289d1 522 else {
46cb090f 523 $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
946289d1 524 }
26fbace8 525
946289d1 526 }
527 else {
26fbace8 528
946289d1 529 return $self->SUPER::get_value($instance);
26fbace8 530 }
946289d1 531}
a15dff8d 532
26fbace8 533## installing accessors
c0e30cf5 534
d617b644 535sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
d7f17ebb 536
452bac1b 537sub install_accessors {
538 my $self = shift;
26fbace8 539 $self->SUPER::install_accessors(@_);
e606ae5f 540 $self->install_delegation if $self->has_handles;
541 return;
542}
26fbace8 543
e1d6f0a3 544sub remove_accessors {
545 my $self = shift;
546 $self->SUPER::remove_accessors(@_);
547 $self->remove_delegation if $self->has_handles;
548 return;
549}
550
e606ae5f 551sub install_delegation {
552 my $self = shift;
26fbace8 553
e606ae5f 554 # NOTE:
555 # Here we canonicalize the 'handles' option
556 # this will sort out any details and always
557 # return an hash of methods which we want
558 # to delagate to, see that method for details
559 my %handles = $self->_canonicalize_handles;
560
e606ae5f 561
562 # install the delegation ...
563 my $associated_class = $self->associated_class;
564 foreach my $handle (keys %handles) {
565 my $method_to_call = $handles{$handle};
566 my $class_name = $associated_class->name;
567 my $name = "${class_name}::${handle}";
26fbace8 568
452bac1b 569 (!$associated_class->has_method($handle))
cee532a1 570 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
26fbace8 571
e606ae5f 572 # NOTE:
573 # handles is not allowed to delegate
574 # any of these methods, as they will
575 # override the ones in your class, which
576 # is almost certainly not what you want.
4fe78472 577
e606ae5f 578 # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
579 #cluck("Not delegating method '$handle' because it is a core method") and
580 next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
26fbace8 581
46f7e6a5 582 my $method = $self->_make_delegation_method($handle, $method_to_call);
a05f85c1 583
584 $self->associated_class->add_method($method->name, $method);
d03bd989 585 }
452bac1b 586}
587
e1d6f0a3 588sub remove_delegation {
589 my $self = shift;
590 my %handles = $self->_canonicalize_handles;
591 my $associated_class = $self->associated_class;
592 foreach my $handle (keys %handles) {
593 $self->associated_class->remove_method($handle);
594 }
595}
596
98aae381 597# private methods to help delegation ...
598
452bac1b 599sub _canonicalize_handles {
600 my $self = shift;
601 my $handles = $self->handles;
c84f324f 602 if (my $handle_type = ref($handles)) {
603 if ($handle_type eq 'HASH') {
604 return %{$handles};
605 }
606 elsif ($handle_type eq 'ARRAY') {
607 return map { $_ => $_ } @{$handles};
608 }
609 elsif ($handle_type eq 'Regexp') {
610 ($self->has_type_constraint)
0286711b 611 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
26fbace8 612 return map { ($_ => $_) }
c84f324f 613 grep { /$handles/ } $self->_get_delegate_method_list;
614 }
615 elsif ($handle_type eq 'CODE') {
616 return $handles->($self, $self->_find_delegate_metaclass);
617 }
618 else {
be05faea 619 $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
c84f324f 620 }
452bac1b 621 }
622 else {
c8d9f1e2 623 Class::MOP::load_class($handles);
624 my $role_meta = Class::MOP::class_of($handles);
c84f324f 625
626 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
425ca605 627 || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
d03bd989 628
c84f324f 629 return map { $_ => $_ } (
26fbace8 630 $role_meta->get_method_list,
c84f324f 631 $role_meta->get_required_method_list
632 );
452bac1b 633 }
634}
635
636sub _find_delegate_metaclass {
637 my $self = shift;
98aae381 638 if (my $class = $self->_isa_metadata) {
9031e2c4 639 # we might be dealing with a non-Moose class,
640 # and need to make our own metaclass. if there's
641 # already a metaclass, it will be returned
452bac1b 642 return Moose::Meta::Class->initialize($class);
643 }
98aae381 644 elsif (my $role = $self->_does_metadata) {
91e6653b 645 return Class::MOP::class_of($role);
452bac1b 646 }
647 else {
be05faea 648 $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
452bac1b 649 }
650}
651
652sub _get_delegate_method_list {
653 my $self = shift;
654 my $meta = $self->_find_delegate_metaclass;
655 if ($meta->isa('Class::MOP::Class')) {
e606ae5f 656 return map { $_->name } # NOTE: !never! delegate &meta
657 grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
658 $meta->get_all_methods;
452bac1b 659 }
660 elsif ($meta->isa('Moose::Meta::Role')) {
26fbace8 661 return $meta->get_method_list;
452bac1b 662 }
663 else {
be05faea 664 $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
452bac1b 665 }
666}
667
bd1226e2 668sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
669
a05f85c1 670sub _make_delegation_method {
46f7e6a5 671 my ( $self, $handle_name, $method_to_call ) = @_;
a05f85c1 672
673 my $method_body;
674
46f7e6a5 675 $method_body = $method_to_call
676 if 'CODE' eq ref($method_to_call);
a05f85c1 677
bd1226e2 678 return $self->delegation_metaclass->new(
46f7e6a5 679 name => $handle_name,
680 package_name => $self->associated_class->name,
681 attribute => $self,
682 delegate_to_method => $method_to_call,
a05f85c1 683 );
684}
685
9c9563c7 686sub _coerce_and_verify {
687 my $self = shift;
688 my $val = shift;
689 my $instance = shift;
690
691 return $val unless $self->has_type_constraint;
692
693 my $type_constraint = $self->type_constraint;
694 if ($self->should_coerce && $type_constraint->has_coercion) {
695 $val = $type_constraint->coerce($val);
696 }
697
698 $self->verify_against_type_constraint($val, instance => $instance);
699
700 return $val;
701}
702
5755a9b2 703sub verify_against_type_constraint {
2b86e02b 704 my $self = shift;
705 my $val = shift;
706
707 return 1 if !$self->has_type_constraint;
708
709 my $type_constraint = $self->type_constraint;
710
711 $type_constraint->check($val)
712 || $self->throw_error("Attribute ("
713 . $self->name
714 . ") does not pass the type constraint because: "
715 . $type_constraint->get_message($val), data => $val, @_);
716}
717
21f1e231 718package Moose::Meta::Attribute::Custom::Moose;
719sub register_implementation { 'Moose::Meta::Attribute' }
720
c0e30cf5 7211;
722
723__END__
724
725=pod
726
727=head1 NAME
728
6ba6d68c 729Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5 730
731=head1 DESCRIPTION
732
93a708fd 733This class is a subclass of L<Class::MOP::Attribute> that provides
734additional Moose-specific functionality.
6ba6d68c 735
7854b409 736To really understand this class, you will need to start with the
737L<Class::MOP::Attribute> documentation. This class can be understood
738as a set of additional features on top of the basic feature provided
739by that parent class.
e522431d 740
d4b1449e 741=head1 INHERITANCE
742
743C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
744
c0e30cf5 745=head1 METHODS
746
93a708fd 747Many of the documented below override methods in
748L<Class::MOP::Attribute> and add Moose specific features.
6ba6d68c 749
93a708fd 750=head2 Creation
6ba6d68c 751
c0e30cf5 752=over 4
753
93a708fd 754=item B<< Moose::Meta::Attribute->new(%options) >>
c0e30cf5 755
93a708fd 756This method overrides the L<Class::MOP::Attribute> constructor.
c32c2c61 757
93a708fd 758Many of the options below are described in more detail in the
759L<Moose::Manual::Attributes> document.
6e2840b7 760
93a708fd 761It adds the following options to the constructor:
d500266f 762
93a708fd 763=over 8
452bac1b 764
93a708fd 765=item * is => 'ro' or 'rw'
e1d6f0a3 766
93a708fd 767This provides a shorthand for specifying the C<reader>, C<writer>, or
768C<accessor> names. If the attribute is read-only ('ro') then it will
769have a C<reader> method with the same attribute as the name.
e606ae5f 770
93a708fd 771If it is read-write ('rw') then it will have an C<accessor> method
772with the same name. If you provide an explicit C<writer> for a
773read-write attribute, then you will have a C<reader> with the same
774name as the attribute, and a C<writer> with the name you provided.
e1d6f0a3 775
93a708fd 776=item * isa => $type
39b3bc94 777
93a708fd 778This option accepts a type. The type can be a string, which should be
779a type name. If the type name is unknown, it is assumed to be a class
780name.
781
782This option can also accept a L<Moose::Meta::TypeConstraint> object.
783
784If you I<also> provide a C<does> option, then your C<isa> option must
785be a class name, and that class must do the role specified with
786C<does>.
787
788=item * does => $role
789
790This is short-hand for saying that the attribute's type must be an
791object which does the named role.
792
793=item * coerce => $bool
794
795This option is only valid for objects with a type constraint
796(C<isa>). If this is true, then coercions will be applied whenever
797this attribute is set.
798
799You can make both this and the C<weak_ref> option true.
800
801=item * trigger => $sub
802
803This option accepts a subroutine reference, which will be called after
804the attribute is set.
805
806=item * required => $bool
807
808An attribute which is required must be provided to the constructor. An
809attribute which is required can also have a C<default> or C<builder>,
36741534 810which will satisfy its required-ness.
93a708fd 811
812A required attribute must have a C<default>, C<builder> or a
813non-C<undef> C<init_arg>
814
815=item * lazy => $bool
816
817A lazy attribute must have a C<default> or C<builder>. When an
818attribute is lazy, the default value will not be calculated until the
819attribute is read.
820
821=item * weak_ref => $bool
822
823If this is true, the attribute's value will be stored as a weak
824reference.
825
826=item * auto_deref => $bool
827
828If this is true, then the reader will dereference the value when it is
829called. The attribute must have a type constraint which defines the
830attribute as an array or hash reference.
831
832=item * lazy_build => $bool
833
834Setting this to true makes the attribute lazy and provides a number of
835default methods.
836
837 has 'size' => (
838 is => 'ro',
839 lazy_build => 1,
840 );
841
842is equivalent to this:
843
844 has 'size' => (
845 is => 'ro',
846 lazy => 1,
847 builder => '_build_size',
848 clearer => 'clear_size',
849 predicate => 'has_size',
850 );
851
852=item * documentation
853
854An arbitrary string that can be retrieved later by calling C<<
855$attr->documentation >>.
856
857=back
858
859=item B<< $attr->clone(%options) >>
860
861This creates a new attribute based on attribute being cloned. You must
862supply a C<name> option to provide a new name for the attribute.
863
864The C<%options> can only specify options handled by
865L<Class::MOP::Attribute>.
866
36741534 867=back
868
93a708fd 869=head2 Value management
870
36741534 871=over 4
872
93a708fd 873=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
874
875This method is used internally to initialize the attribute's slot in
876the object C<$instance>.
877
878This overrides the L<Class::MOP::Attribute> method to handle lazy
879attributes, weak references, and type constraints.
bd1226e2 880
946289d1 881=item B<get_value>
882
883=item B<set_value>
884
6549b0d1 885 eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
bcbaa845 886 if($@) {
887 print "Oops: $@\n";
888 }
889
6549b0d1 890I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
bcbaa845 891
892Before setting the value, a check is made on the type constraint of
893the attribute, if it has one, to see if the value passes it. If the
46cb090f 894value fails to pass, the set operation dies with a L<throw_error>.
bcbaa845 895
896Any coercion to convert values is done before checking the type constraint.
897
898To check a value against a type constraint before setting it, fetch the
ec00fa75 899attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
bcbaa845 900fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
e606ae5f 901and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
bcbaa845 902for an example.
903
a15dff8d 904=back
905
93a708fd 906=head2 Attribute Accessor generation
6ba6d68c 907
a15dff8d 908=over 4
909
93a708fd 910=item B<< $attr->install_accessors >>
be05faea 911
93a708fd 912This method overrides the parent to also install delegation methods.
be05faea 913
36741534 914=item B<< $attr->remove_accessors >>
d5c30e52 915
93a708fd 916This method overrides the parent to also remove delegation methods.
d5c30e52 917
93a708fd 918=item B<< $attr->install_delegation >>
919
920This method adds its delegation methods to the attribute's associated
921class, if it has any to add.
922
923=item B<< $attr->remove_delegation >>
924
925This method remove its delegation methods from the attribute's
926associated class.
d5c30e52 927
93a708fd 928=item B<< $attr->accessor_metaclass >>
9e93dd19 929
93a708fd 930Returns the accessor metaclass name, which defaults to
931L<Moose::Meta::Method::Accessor>.
932
933=item B<< $attr->delegation_metaclass >>
934
935Returns the delegation metaclass name, which defaults to
936L<Moose::Meta::Method::Delegation>.
937
938=back
939
940=head2 Additional Moose features
941
942These methods are not found in the superclass. They support features
943provided by Moose.
944
36741534 945=over 4
946
93a708fd 947=item B<< $attr->does($role) >>
948
949This indicates whether the I<attribute itself> does the given
36741534 950role. The role can be given as a full class name, or as a resolvable
93a708fd 951trait name.
952
953Note that this checks the attribute itself, not its type constraint,
954so it is checking the attribute's metaclass and any traits applied to
955the attribute.
956
957=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
958
959This is an alternate constructor that handles the C<metaclass> and
960C<traits> options.
9e93dd19 961
93a708fd 962Effectively, this method is a factory that finds or creates the
36741534 963appropriate class for the given C<metaclass> and/or C<traits>.
e606ae5f 964
93a708fd 965Once it has the appropriate class, it will call C<< $class->new($name,
966%options) >> on that class.
e606ae5f 967
93a708fd 968=item B<< $attr->clone_and_inherit_options(%options) >>
a15dff8d 969
93a708fd 970This method supports the C<has '+foo'> feature. It does various bits
971of processing on the supplied C<%options> before ultimately calling
972the C<clone> method.
6ba6d68c 973
93a708fd 974One of its main tasks is to make sure that the C<%options> provided
975only includes the options returned by the
976C<legal_options_for_inheritance> method.
a15dff8d 977
93a708fd 978=item B<< $attr->legal_options_for_inheritance >>
a15dff8d 979
93a708fd 980This returns a whitelist of options that can be overridden in a
981subclass's attribute definition.
2b86e02b 982
93a708fd 983This exists to allow a custom metaclass to change or add to the list
984of options which can be changed.
2b86e02b 985
93a708fd 986=item B<< $attr->type_constraint >>
452bac1b 987
93a708fd 988Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
989if it has one.
452bac1b 990
93a708fd 991=item B<< $attr->has_type_constraint >>
452bac1b 992
93a708fd 993Returns true if this attribute has a type constraint.
452bac1b 994
93a708fd 995=item B<< $attr->verify_against_type_constraint($value) >>
a15dff8d 996
93a708fd 997Given a value, this method returns true if the value is valid for the
998attribute's type constraint. If the value is not valid, it throws an
999error.
4b598ea3 1000
93a708fd 1001=item B<< $attr->handles >>
ca01a97b 1002
93a708fd 1003This returns the value of the C<handles> option passed to the
1004constructor.
ca01a97b 1005
93a708fd 1006=item B<< $attr->has_handles >>
ca01a97b 1007
93a708fd 1008Returns true if this attribute performs delegation.
ca01a97b 1009
93a708fd 1010=item B<< $attr->is_weak_ref >>
26fbace8 1011
93a708fd 1012Returns true if this attribute stores its value as a weak reference.
26fbace8 1013
93a708fd 1014=item B<< $attr->is_required >>
26fbace8 1015
93a708fd 1016Returns true if this attribute is required to have a value.
26fbace8 1017
93a708fd 1018=item B<< $attr->is_lazy >>
58f85113 1019
93a708fd 1020Returns true if this attribute is lazy.
26fbace8 1021
93a708fd 1022=item B<< $attr->is_lazy_build >>
ca01a97b 1023
93a708fd 1024Returns true if the C<lazy_build> option was true when passed to the
1025constructor.
4b598ea3 1026
93a708fd 1027=item B<< $attr->should_coerce >>
6ba6d68c 1028
93a708fd 1029Returns true if the C<coerce> option passed to the constructor was
1030true.
536f0b17 1031
93a708fd 1032=item B<< $attr->should_auto_deref >>
536f0b17 1033
93a708fd 1034Returns true if the C<auto_deref> option passed to the constructor was
1035true.
536f0b17 1036
93a708fd 1037=item B<< $attr->trigger >>
8c9d74e7 1038
93a708fd 1039This is the subroutine reference that was in the C<trigger> option
1040passed to the constructor, if any.
02a0fb52 1041
36741534 1042=item B<< $attr->has_trigger >>
8c9d74e7 1043
93a708fd 1044Returns true if this attribute has a trigger set.
02a0fb52 1045
93a708fd 1046=item B<< $attr->documentation >>
ddbdc0cb 1047
93a708fd 1048Returns the value that was in the C<documentation> option passed to
1049the constructor, if any.
ddbdc0cb 1050
93a708fd 1051=item B<< $attr->has_documentation >>
ddbdc0cb 1052
93a708fd 1053Returns true if this attribute has any documentation.
ddbdc0cb 1054
93a708fd 1055=item B<< $attr->applied_traits >>
88f23977 1056
93a708fd 1057This returns an array reference of all the traits which were applied
1058to this attribute. If none were applied, this returns C<undef>.
88f23977 1059
93a708fd 1060=item B<< $attr->has_applied_traits >>
88f23977 1061
93a708fd 1062Returns true if this attribute has any traits applied.
88f23977 1063
c0e30cf5 1064=back
1065
1066=head1 BUGS
1067
26fbace8 1068All complex software has bugs lurking in it, and this module is no
c0e30cf5 1069exception. If you find a bug please either email me, or add the bug
1070to cpan-RT.
1071
c0e30cf5 1072=head1 AUTHOR
1073
1074Stevan Little E<lt>stevan@iinteractive.comE<gt>
1075
98aae381 1076Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1077
c0e30cf5 1078=head1 COPYRIGHT AND LICENSE
1079
2840a3b2 1080Copyright 2006-2009 by Infinity Interactive, Inc.
c0e30cf5 1081
1082L<http://www.iinteractive.com>
1083
1084This library is free software; you can redistribute it and/or modify
26fbace8 1085it under the same terms as Perl itself.
c0e30cf5 1086
8a7a9c53 1087=cut