Fix all references to cookbook recipes
[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';
a15dff8d 8use Carp 'confess';
a909a4df 9use overload ();
a15dff8d 10
330dbb07 11our $VERSION = '0.55';
d44714be 12our $AUTHORITY = 'cpan:STEVAN';
78cd1d3b 13
8ee73eeb 14use Moose::Meta::Method::Accessor;
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
587e457d 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
64 return Moose::Object::does($self, $name);
65}
587e457d 66
78cd1d3b 67sub new {
f3c4e20e 68 my ($class, $name, %options) = @_;
c32c2c61 69 $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
f3c4e20e 70 return $class->SUPER::new($name, %options);
1d768fb1 71}
72
d5c30e52 73sub interpolate_class_and_new {
74 my ($class, $name, @args) = @_;
75
c32c2c61 76 my ( $new_class, @traits ) = $class->interpolate_class(@args);
77
78 $new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
d5c30e52 79}
80
81sub interpolate_class {
82 my ($class, %options) = @_;
83
c32c2c61 84 $class = ref($class) || $class;
85
86 if ( my $metaclass_name = delete $options{metaclass} ) {
87 my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
88
89 if ( $class ne $new_class ) {
90 if ( $new_class->can("interpolate_class") ) {
91 return $new_class->interpolate_class(%options);
92 } else {
93 $class = $new_class;
94 }
95 }
d5c30e52 96 }
97
c32c2c61 98 my @traits;
99
d5c30e52 100 if (my $traits = $options{traits}) {
c32c2c61 101 if ( @traits = grep { not $class->does($_) } map {
d5c30e52 102 Moose::Util::resolve_metatrait_alias( Attribute => $_ )
103 or
104 $_
c32c2c61 105 } @$traits ) {
106 my $anon_class = Moose::Meta::Class->create_anon_class(
107 superclasses => [ $class ],
108 roles => [ @traits ],
109 cache => 1,
110 );
111
112 $class = $anon_class->name;
113 }
d5c30e52 114 }
c32c2c61 115
116 return ( wantarray ? ( $class, @traits ) : $class );
d5c30e52 117}
118
713b0244 119# ...
120
121my @legal_options_for_inheritance = qw(
122 default coerce required
123 documentation lazy handles
124 builder type_constraint
125);
126
127sub legal_options_for_inheritance { @legal_options_for_inheritance }
128
129# NOTE/TODO
130# This method *must* be able to handle
131# Class::MOP::Attribute instances as
132# well. Yes, I know that is wrong, but
133# apparently we didn't realize it was
134# doing that and now we have some code
135# which is dependent on it. The real
136# solution of course is to push this
137# feature back up into Class::MOP::Attribute
138# but I not right now, I am too lazy.
139# However if you are reading this and
140# looking for something to do,.. please
141# be my guest.
142# - stevan
ce0e8d63 143sub clone_and_inherit_options {
144 my ($self, %options) = @_;
713b0244 145
c32c2c61 146 my %copy = %options;
713b0244 147
ce0e8d63 148 my %actual_options;
713b0244 149
150 # NOTE:
151 # we may want to extends a Class::MOP::Attribute
152 # in which case we need to be able to use the
153 # core set of legal options that have always
154 # been here. But we allows Moose::Meta::Attribute
155 # instances to changes them.
156 # - SL
157 my @legal_options = $self->can('legal_options_for_inheritance')
158 ? $self->legal_options_for_inheritance
159 : @legal_options_for_inheritance;
160
161 foreach my $legal_option (@legal_options) {
ce0e8d63 162 if (exists $options{$legal_option}) {
163 $actual_options{$legal_option} = $options{$legal_option};
164 delete $options{$legal_option};
165 }
713b0244 166 }
26fbace8 167
ce0e8d63 168 if ($options{isa}) {
169 my $type_constraint;
8de73ff1 170 if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
171 $type_constraint = $options{isa};
172 }
173 else {
d40ce9d5 174 $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
8de73ff1 175 (defined $type_constraint)
176 || confess "Could not find the type constraint '" . $options{isa} . "'";
177 }
5e98d2b6 178
8de73ff1 179 $actual_options{type_constraint} = $type_constraint;
ce0e8d63 180 delete $options{isa};
181 }
2ea379cb 182
183 if ($options{does}) {
184 my $type_constraint;
185 if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
186 $type_constraint = $options{does};
187 }
188 else {
d40ce9d5 189 $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
2ea379cb 190 (defined $type_constraint)
191 || confess "Could not find the type constraint '" . $options{does} . "'";
192 }
193
194 $actual_options{type_constraint} = $type_constraint;
195 delete $options{does};
196 }
c32c2c61 197
cbd141ca 198 # NOTE:
199 # this doesn't apply to Class::MOP::Attributes,
200 # so we can ignore it for them.
201 # - SL
202 if ($self->can('interpolate_class')) {
203 ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(%options);
c32c2c61 204
cbd141ca 205 my %seen;
206 my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
207 $actual_options{traits} = \@all_traits if @all_traits;
c32c2c61 208
cbd141ca 209 delete @options{qw(metaclass traits)};
210 }
c32c2c61 211
26fbace8 212 (scalar keys %options == 0)
ce0e8d63 213 || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
c32c2c61 214
215
ce0e8d63 216 $self->clone(%actual_options);
1d768fb1 217}
218
c32c2c61 219sub clone {
220 my ( $self, %params ) = @_;
221
222 my $class = $params{metaclass} || ref $self;
223
224 if ( 0 and $class eq ref $self ) {
225 return $self->SUPER::clone(%params);
226 } else {
227 my ( @init, @non_init );
228
229 foreach my $attr ( grep { $_->has_value($self) } $self->meta->compute_all_applicable_attributes ) {
230 push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
231 }
232
233 my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
234
235 my $name = delete $new_params{name};
236
237 my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
238
239 foreach my $attr ( @non_init ) {
240 $attr->set_value($clone, $attr->get_value($self));
241 }
242
243
244 return $clone;
245 }
246}
247
1d768fb1 248sub _process_options {
249 my ($class, $name, $options) = @_;
8de73ff1 250
f3c4e20e 251 if (exists $options->{is}) {
21f1e231 252
012fcbd1 253 ### -------------------------
254 ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
255 ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
256 ## is => rw, accessor => _foo # turns into (accessor => _foo)
257 ## is => ro, accessor => _foo # error, accesor is rw
258 ### -------------------------
21f1e231 259
8de73ff1 260 if ($options->{is} eq 'ro') {
21f1e231 261 confess "Cannot define an accessor name on a read-only attribute, accessors are read/write"
262 if exists $options->{accessor};
8de73ff1 263 $options->{reader} ||= $name;
8de73ff1 264 }
265 elsif ($options->{is} eq 'rw') {
21f1e231 266 if ($options->{writer}) {
267 $options->{reader} ||= $name;
268 }
269 else {
270 $options->{accessor} ||= $name;
271 }
8de73ff1 272 }
273 else {
173709ca 274 confess "I do not understand this option (is => " . $options->{is} . ") on attribute ($name)"
8de73ff1 275 }
f3c4e20e 276 }
8de73ff1 277
f3c4e20e 278 if (exists $options->{isa}) {
f3c4e20e 279 if (exists $options->{does}) {
280 if (eval { $options->{isa}->can('does') }) {
281 ($options->{isa}->does($options->{does}))
173709ca 282 || confess "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)";
f3c4e20e 283 }
284 else {
173709ca 285 confess "Cannot have an isa option which cannot ->does() on attribute ($name)";
26fbace8 286 }
26fbace8 287 }
8de73ff1 288
f3c4e20e 289 # allow for anon-subtypes here ...
290 if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
8de73ff1 291 $options->{type_constraint} = $options->{isa};
292 }
293 else {
620db045 294 $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
8de73ff1 295 }
f3c4e20e 296 }
297 elsif (exists $options->{does}) {
298 # allow for anon-subtypes here ...
299 if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
238b424d 300 $options->{type_constraint} = $options->{does};
8de73ff1 301 }
302 else {
620db045 303 $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
8de73ff1 304 }
f3c4e20e 305 }
8de73ff1 306
f3c4e20e 307 if (exists $options->{coerce} && $options->{coerce}) {
308 (exists $options->{type_constraint})
173709ca 309 || confess "You cannot have coercion without specifying a type constraint on attribute ($name)";
310 confess "You cannot have a weak reference to a coerced value on attribute ($name)"
8de73ff1 311 if $options->{weak_ref};
f3c4e20e 312 }
8de73ff1 313
0b7df53c 314 if (exists $options->{trigger}) {
65e14c86 315 ('CODE' eq ref $options->{trigger})
316 || confess "Trigger must be a CODE ref on attribute ($name)";
0b7df53c 317 }
318
f3c4e20e 319 if (exists $options->{auto_deref} && $options->{auto_deref}) {
320 (exists $options->{type_constraint})
173709ca 321 || confess "You cannot auto-dereference without specifying a type constraint on attribute ($name)";
f3c4e20e 322 ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
8de73ff1 323 $options->{type_constraint}->is_a_type_of('HashRef'))
173709ca 324 || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)";
f3c4e20e 325 }
8de73ff1 326
f3c4e20e 327 if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
173709ca 328 confess("You can not use lazy_build and default for the same attribute ($name)")
8de73ff1 329 if exists $options->{default};
a6c84c69 330 $options->{lazy} = 1;
331 $options->{required} = 1;
332 $options->{builder} ||= "_build_${name}";
333 if ($name =~ /^_/) {
f3c4e20e 334 $options->{clearer} ||= "_clear${name}";
335 $options->{predicate} ||= "_has${name}";
a6c84c69 336 }
337 else {
f3c4e20e 338 $options->{clearer} ||= "clear_${name}";
339 $options->{predicate} ||= "has_${name}";
26fbace8 340 }
f3c4e20e 341 }
8de73ff1 342
f3c4e20e 343 if (exists $options->{lazy} && $options->{lazy}) {
9edba990 344 (exists $options->{default} || defined $options->{builder} )
7dbda458 345 || confess "You cannot have lazy attribute ($name) without specifying a default value for it";
f3c4e20e 346 }
26fbace8 347
9edba990 348 if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
7dbda458 349 confess "You cannot have a required attribute ($name) without a default, builder, or an init_arg";
9edba990 350 }
351
78cd1d3b 352}
c0e30cf5 353
d500266f 354sub initialize_instance_slot {
ddd0ec20 355 my ($self, $meta_instance, $instance, $params) = @_;
d500266f 356 my $init_arg = $self->init_arg();
357 # try to fetch the init arg from the %params ...
ddd0ec20 358
26fbace8 359 my $val;
1ed0b94f 360 my $value_is_set;
625d571f 361 if ( defined($init_arg) and exists $params->{$init_arg}) {
d500266f 362 $val = $params->{$init_arg};
2c78d811 363 $value_is_set = 1;
d500266f 364 }
365 else {
366 # skip it if it's lazy
367 return if $self->is_lazy;
368 # and die if it's required and doesn't have a default value
26fbace8 369 confess "Attribute (" . $self->name . ") is required"
370 if $self->is_required && !$self->has_default && !$self->has_builder;
ddd0ec20 371
1ed0b94f 372 # if nothing was in the %params, we can use the
373 # attribute's default value (if it has one)
374 if ($self->has_default) {
375 $val = $self->default($instance);
376 $value_is_set = 1;
a6c84c69 377 }
378 elsif ($self->has_builder) {
379 if (my $builder = $instance->can($self->builder)){
1ed0b94f 380 $val = $instance->$builder;
381 $value_is_set = 1;
a6c84c69 382 }
383 else {
0b26305c 384 confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
1ed0b94f 385 }
a0748c37 386 }
26fbace8 387 }
388
1ed0b94f 389 return unless $value_is_set;
390
391 if ($self->has_type_constraint) {
392 my $type_constraint = $self->type_constraint;
393 if ($self->should_coerce && $type_constraint->has_coercion) {
394 $val = $type_constraint->coerce($val);
d500266f 395 }
ab76842e 396 $type_constraint->check($val)
688fcdda 397 || confess "Attribute ("
398 . $self->name
399 . ") does not pass the type constraint because: "
400 . $type_constraint->get_message($val);
1ed0b94f 401 }
ddd0ec20 402
65e14c86 403 $self->set_initial_value($instance, $val);
404 $meta_instance->weaken_slot_value($instance, $self->name)
405 if ref $val && $self->is_weak_ref;
d500266f 406}
407
d617b644 408## Slot management
9e93dd19 409
8abe9636 410# FIXME:
411# this duplicates too much code from
412# Class::MOP::Attribute, we need to
413# refactor these bits eventually.
414# - SL
415sub _set_initial_slot_value {
416 my ($self, $meta_instance, $instance, $value) = @_;
417
418 my $slot_name = $self->name;
419
420 return $meta_instance->set_slot_value($instance, $slot_name, $value)
421 unless $self->has_initializer;
422
423 my ($type_constraint, $can_coerce);
424 if ($self->has_type_constraint) {
425 $type_constraint = $self->type_constraint;
426 $can_coerce = ($self->should_coerce && $type_constraint->has_coercion);
427 }
428
429 my $callback = sub {
430 my $val = shift;
431 if ($type_constraint) {
432 $val = $type_constraint->coerce($val)
433 if $can_coerce;
434 $type_constraint->check($val)
435 || confess "Attribute ("
436 . $slot_name
437 . ") does not pass the type constraint because: "
438 . $type_constraint->get_message($val);
439 }
440 $meta_instance->set_slot_value($instance, $slot_name, $val);
441 };
442
443 my $initializer = $self->initializer;
444
445 # most things will just want to set a value, so make it first arg
446 $instance->$initializer($value, $callback, $self);
447}
448
946289d1 449sub set_value {
b6af66f8 450 my ($self, $instance, @args) = @_;
451 my $value = $args[0];
26fbace8 452
946289d1 453 my $attr_name = $self->name;
26fbace8 454
b6af66f8 455 if ($self->is_required and not @args) {
456 confess "Attribute ($attr_name) is required";
946289d1 457 }
26fbace8 458
946289d1 459 if ($self->has_type_constraint) {
26fbace8 460
946289d1 461 my $type_constraint = $self->type_constraint;
26fbace8 462
946289d1 463 if ($self->should_coerce) {
26fbace8 464 $value = $type_constraint->coerce($value);
688fcdda 465 }
42bc21a4 466 $type_constraint->_compiled_type_constraint->($value)
688fcdda 467 || confess "Attribute ("
468 . $self->name
469 . ") does not pass the type constraint because "
ab76842e 470 . $type_constraint->get_message($value);
946289d1 471 }
26fbace8 472
65e14c86 473 my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
474 ->get_meta_instance;
475
476 $meta_instance->set_slot_value($instance, $attr_name, $value);
477
478 if (ref $value && $self->is_weak_ref) {
479 $meta_instance->weaken_slot_value($instance, $attr_name);
480 }
481
482 if ($self->has_trigger) {
483 $self->trigger->($instance, $value, $self);
484 }
946289d1 485}
486
487sub get_value {
488 my ($self, $instance) = @_;
26fbace8 489
946289d1 490 if ($self->is_lazy) {
8de73ff1 491 unless ($self->has_value($instance)) {
492 if ($self->has_default) {
493 my $default = $self->default($instance);
759e4e8f 494 $self->set_initial_value($instance, $default);
3f11800d 495 } elsif ( $self->has_builder ) {
a6c84c69 496 if (my $builder = $instance->can($self->builder)){
759e4e8f 497 $self->set_initial_value($instance, $instance->$builder);
3f11800d 498 }
a6c84c69 499 else {
500 confess(blessed($instance)
501 . " does not support builder method '"
502 . $self->builder
503 . "' for attribute '"
504 . $self->name
505 . "'");
26fbace8 506 }
a6c84c69 507 }
508 else {
759e4e8f 509 $self->set_initial_value($instance, undef);
26fbace8 510 }
8de73ff1 511 }
946289d1 512 }
26fbace8 513
946289d1 514 if ($self->should_auto_deref) {
26fbace8 515
946289d1 516 my $type_constraint = $self->type_constraint;
517
518 if ($type_constraint->is_a_type_of('ArrayRef')) {
519 my $rv = $self->SUPER::get_value($instance);
520 return unless defined $rv;
521 return wantarray ? @{ $rv } : $rv;
26fbace8 522 }
946289d1 523 elsif ($type_constraint->is_a_type_of('HashRef')) {
524 my $rv = $self->SUPER::get_value($instance);
525 return unless defined $rv;
526 return wantarray ? %{ $rv } : $rv;
26fbace8 527 }
946289d1 528 else {
529 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
530 }
26fbace8 531
946289d1 532 }
533 else {
26fbace8 534
946289d1 535 return $self->SUPER::get_value($instance);
26fbace8 536 }
946289d1 537}
a15dff8d 538
26fbace8 539## installing accessors
c0e30cf5 540
d617b644 541sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
d7f17ebb 542
452bac1b 543sub install_accessors {
544 my $self = shift;
26fbace8 545 $self->SUPER::install_accessors(@_);
d3e7fe85 546 $self->install_delegation if $self->has_handles;
547 return;
548}
26fbace8 549
d3e7fe85 550sub install_delegation {
551 my $self = shift;
26fbace8 552
d3e7fe85 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
330dbb07 558 my %handles = $self->_canonicalize_handles;
d3e7fe85 559
560 # find the accessor method for this attribute
330dbb07 561 my $accessor = $self->_get_delegate_accessor;
d3e7fe85 562
563 # install the delegation ...
564 my $associated_class = $self->associated_class;
565 foreach my $handle (keys %handles) {
566 my $method_to_call = $handles{$handle};
567 my $class_name = $associated_class->name;
568 my $name = "${class_name}::${handle}";
569
570 (!$associated_class->has_method($handle))
571 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
26fbace8 572
d3e7fe85 573 # NOTE:
574 # handles is not allowed to delegate
575 # any of these methods, as they will
576 # override the ones in your class, which
577 # is almost certainly not what you want.
4fe78472 578
d3e7fe85 579 # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
580 #cluck("Not delegating method '$handle' because it is a core method") and
581 next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
26fbace8 582
d3e7fe85 583 if ('CODE' eq ref($method_to_call)) {
584 $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
452bac1b 585 }
d3e7fe85 586 else {
587 # NOTE:
588 # we used to do a goto here, but the
589 # goto didn't handle failure correctly
590 # (it just returned nothing), so I took
591 # that out. However, the more I thought
592 # about it, the less I liked it doing
593 # the goto, and I prefered the act of
594 # delegation being actually represented
595 # in the stack trace.
596 # - SL
597 $associated_class->add_method($handle => Class::MOP::subname($name, sub {
598 my $proxy = (shift)->$accessor();
599 (defined $proxy)
600 || confess "Cannot delegate $handle to $method_to_call because " .
601 "the value of " . $self->name . " is not defined";
602 $proxy->$method_to_call(@_);
603 }));
604 }
605 }
452bac1b 606}
607
98aae381 608# private methods to help delegation ...
609
330dbb07 610sub _get_delegate_accessor {
611 my $self = shift;
612 # find the accessor method for this attribute
613 my $accessor = $self->get_read_method_ref;
614 # then unpack it if we need too ...
615 $accessor = $accessor->body if blessed $accessor;
616 # return the accessor
617 return $accessor;
618}
619
452bac1b 620sub _canonicalize_handles {
621 my $self = shift;
622 my $handles = $self->handles;
c84f324f 623 if (my $handle_type = ref($handles)) {
624 if ($handle_type eq 'HASH') {
625 return %{$handles};
626 }
627 elsif ($handle_type eq 'ARRAY') {
628 return map { $_ => $_ } @{$handles};
629 }
630 elsif ($handle_type eq 'Regexp') {
631 ($self->has_type_constraint)
632 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
26fbace8 633 return map { ($_ => $_) }
c84f324f 634 grep { /$handles/ } $self->_get_delegate_method_list;
635 }
636 elsif ($handle_type eq 'CODE') {
637 return $handles->($self, $self->_find_delegate_metaclass);
638 }
639 else {
640 confess "Unable to canonicalize the 'handles' option with $handles";
641 }
452bac1b 642 }
643 else {
c84f324f 644 my $role_meta = eval { $handles->meta };
645 if ($@) {
26fbace8 646 confess "Unable to canonicalize the 'handles' option with $handles because : $@";
c84f324f 647 }
648
649 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
650 || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
26fbace8 651
c84f324f 652 return map { $_ => $_ } (
26fbace8 653 $role_meta->get_method_list,
c84f324f 654 $role_meta->get_required_method_list
655 );
452bac1b 656 }
657}
658
659sub _find_delegate_metaclass {
660 my $self = shift;
98aae381 661 if (my $class = $self->_isa_metadata) {
26fbace8 662 # if the class does have
452bac1b 663 # a meta method, use it
664 return $class->meta if $class->can('meta');
26fbace8 665 # otherwise we might be
452bac1b 666 # dealing with a non-Moose
26fbace8 667 # class, and need to make
452bac1b 668 # our own metaclass
669 return Moose::Meta::Class->initialize($class);
670 }
98aae381 671 elsif (my $role = $self->_does_metadata) {
26fbace8 672 # our role will always have
452bac1b 673 # a meta method
98aae381 674 return $role->meta;
452bac1b 675 }
676 else {
677 confess "Cannot find delegate metaclass for attribute " . $self->name;
678 }
679}
680
681sub _get_delegate_method_list {
682 my $self = shift;
683 my $meta = $self->_find_delegate_metaclass;
684 if ($meta->isa('Class::MOP::Class')) {
093b12c2 685 return map { $_->{name} } # NOTE: !never! delegate &meta
26fbace8 686 grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
452bac1b 687 $meta->compute_all_applicable_methods;
688 }
689 elsif ($meta->isa('Moose::Meta::Role')) {
26fbace8 690 return $meta->get_method_list;
452bac1b 691 }
692 else {
693 confess "Unable to recognize the delegate metaclass '$meta'";
694 }
695}
696
21f1e231 697package Moose::Meta::Attribute::Custom::Moose;
698sub register_implementation { 'Moose::Meta::Attribute' }
699
c0e30cf5 7001;
701
702__END__
703
704=pod
705
706=head1 NAME
707
6ba6d68c 708Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5 709
710=head1 DESCRIPTION
711
26fbace8 712This is a subclass of L<Class::MOP::Attribute> with Moose specific
713extensions.
6ba6d68c 714
26fbace8 715For the most part, the only time you will ever encounter an
716instance of this class is if you are doing some serious deep
717introspection. To really understand this class, you need to refer
6ba6d68c 718to the L<Class::MOP::Attribute> documentation.
e522431d 719
c0e30cf5 720=head1 METHODS
721
6ba6d68c 722=head2 Overridden methods
723
26fbace8 724These methods override methods in L<Class::MOP::Attribute> and add
725Moose specific features. You can safely assume though that they
6ba6d68c 726will behave just as L<Class::MOP::Attribute> does.
727
c0e30cf5 728=over 4
729
730=item B<new>
731
c32c2c61 732=item B<clone>
733
6e2840b7 734=item B<does>
735
d500266f 736=item B<initialize_instance_slot>
737
452bac1b 738=item B<install_accessors>
739
d3e7fe85 740=item B<install_delegation>
741
39b3bc94 742=item B<accessor_metaclass>
743
946289d1 744=item B<get_value>
745
746=item B<set_value>
747
bcbaa845 748 eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
749 if($@) {
750 print "Oops: $@\n";
751 }
752
753I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
754
755Before setting the value, a check is made on the type constraint of
756the attribute, if it has one, to see if the value passes it. If the
757value fails to pass, the set operation dies with a L<Carp/confess>.
758
759Any coercion to convert values is done before checking the type constraint.
760
761To check a value against a type constraint before setting it, fetch the
ec00fa75 762attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
bcbaa845 763fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
5cfe3805 764and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
bcbaa845 765for an example.
766
a15dff8d 767=back
768
6ba6d68c 769=head2 Additional Moose features
770
26fbace8 771Moose attributes support type-constraint checking, weak reference
772creation and type coercion.
6ba6d68c 773
a15dff8d 774=over 4
775
d5c30e52 776=item B<interpolate_class_and_new>
777
778=item B<interpolate_class>
779
780When called as a class method causes interpretation of the C<metaclass> and
781C<traits> options.
782
9e93dd19 783=item B<clone_and_inherit_options>
784
26fbace8 785This is to support the C<has '+foo'> feature, it clones an attribute
786from a superclass and allows a very specific set of changes to be made
9e93dd19 787to the attribute.
788
aa08864c 789=item B<legal_options_for_inheritance>
790
791Whitelist with options you can change. You can overload it in your custom
792metaclass to allow your options be inheritable.
793
a15dff8d 794=item B<has_type_constraint>
795
6ba6d68c 796Returns true if this meta-attribute has a type constraint.
797
a15dff8d 798=item B<type_constraint>
799
26fbace8 800A read-only accessor for this meta-attribute's type constraint. For
801more information on what you can do with this, see the documentation
6ba6d68c 802for L<Moose::Meta::TypeConstraint>.
a15dff8d 803
452bac1b 804=item B<has_handles>
805
806Returns true if this meta-attribute performs delegation.
807
808=item B<handles>
809
810This returns the value which was passed into the handles option.
811
6ba6d68c 812=item B<is_weak_ref>
a15dff8d 813
02a0fb52 814Returns true if this meta-attribute produces a weak reference.
4b598ea3 815
ca01a97b 816=item B<is_required>
817
02a0fb52 818Returns true if this meta-attribute is required to have a value.
ca01a97b 819
820=item B<is_lazy>
821
02a0fb52 822Returns true if this meta-attribute should be initialized lazily.
ca01a97b 823
26fbace8 824NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
825
826=item B<is_lazy_build>
827
828Returns true if this meta-attribute should be initialized lazily through
829the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
830make your attribute required and lazy. In addition it will set the builder, clearer
831and predicate options for you using the following convention.
832
833 #If your attribute name starts with an underscore:
834 has '_foo' => (lazy_build => 1);
835 #is the same as
4c9e0478 836 has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo');
26fbace8 837 # or
58f85113 838 has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
26fbace8 839
840 #If your attribute name does not start with an underscore:
58f85113 841 has 'foo' => (lazy_build => 1);
842 #is the same as
4c9e0478 843 has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo');
26fbace8 844 # or
58f85113 845 has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
846
847The reason for the different naming of the C<builder> is that the C<builder>
848method is a private method while the C<clearer> and C<predicate> methods
849are public methods.
26fbace8 850
851NOTE: This means your class should provide a method whose name matches the value
58f85113 852of the builder part, in this case _build__foo or _build_foo.
ca01a97b 853
34a66aa3 854=item B<should_coerce>
4b598ea3 855
02a0fb52 856Returns true if this meta-attribute should perform type coercion.
6ba6d68c 857
536f0b17 858=item B<should_auto_deref>
859
26fbace8 860Returns true if this meta-attribute should perform automatic
861auto-dereferencing.
536f0b17 862
26fbace8 863NOTE: This can only be done for attributes whose type constraint is
536f0b17 864either I<ArrayRef> or I<HashRef>.
865
8c9d74e7 866=item B<has_trigger>
867
02a0fb52 868Returns true if this meta-attribute has a trigger set.
869
8c9d74e7 870=item B<trigger>
871
26fbace8 872This is a CODE reference which will be executed every time the
873value of an attribute is assigned. The CODE ref will get two values,
874the invocant and the new value. This can be used to handle I<basic>
02a0fb52 875bi-directional relations.
876
ddbdc0cb 877=item B<documentation>
878
26fbace8 879This is a string which contains the documentation for this attribute.
ddbdc0cb 880It serves no direct purpose right now, but it might in the future
881in some kind of automated documentation system perhaps.
882
883=item B<has_documentation>
884
885Returns true if this meta-attribute has any documentation.
886
88f23977 887=item B<applied_traits>
888
889This will return the ARRAY ref of all the traits applied to this
890attribute, or if no traits have been applied, it returns C<undef>.
891
892=item B<has_applied_traits>
893
894Returns true if this meta-attribute has any traits applied.
895
c0e30cf5 896=back
897
898=head1 BUGS
899
26fbace8 900All complex software has bugs lurking in it, and this module is no
c0e30cf5 901exception. If you find a bug please either email me, or add the bug
902to cpan-RT.
903
c0e30cf5 904=head1 AUTHOR
905
906Stevan Little E<lt>stevan@iinteractive.comE<gt>
907
98aae381 908Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
909
c0e30cf5 910=head1 COPYRIGHT AND LICENSE
911
778db3ac 912Copyright 2006-2008 by Infinity Interactive, Inc.
c0e30cf5 913
914L<http://www.iinteractive.com>
915
916This library is free software; you can redistribute it and/or modify
26fbace8 917it under the same terms as Perl itself.
c0e30cf5 918
8a7a9c53 919=cut