Rename $meta to $super_meta in _fix_metaclass_incompatibility to make
[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
f92cd300 11our $VERSION = '0.57';
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)) {
f92cd300 492 my $value;
8de73ff1 493 if ($self->has_default) {
f92cd300 494 $value = $self->default($instance);
3f11800d 495 } elsif ( $self->has_builder ) {
a6c84c69 496 if (my $builder = $instance->can($self->builder)){
f92cd300 497 $value = $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 }
f92cd300 508 if ($self->has_type_constraint) {
509 my $type_constraint = $self->type_constraint;
510 $value = $type_constraint->coerce($value)
511 if ($self->should_coerce);
512 $type_constraint->check($value)
513 || confess "Attribute (" . $self->name
514 . "') does not pass the type constraint because: "
515 . $type_constraint->get_message($value);
26fbace8 516 }
f92cd300 517 $self->set_initial_value($instance, $value);
8de73ff1 518 }
946289d1 519 }
26fbace8 520
946289d1 521 if ($self->should_auto_deref) {
26fbace8 522
946289d1 523 my $type_constraint = $self->type_constraint;
524
525 if ($type_constraint->is_a_type_of('ArrayRef')) {
526 my $rv = $self->SUPER::get_value($instance);
527 return unless defined $rv;
528 return wantarray ? @{ $rv } : $rv;
26fbace8 529 }
946289d1 530 elsif ($type_constraint->is_a_type_of('HashRef')) {
531 my $rv = $self->SUPER::get_value($instance);
532 return unless defined $rv;
533 return wantarray ? %{ $rv } : $rv;
26fbace8 534 }
946289d1 535 else {
536 confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
537 }
26fbace8 538
946289d1 539 }
540 else {
26fbace8 541
946289d1 542 return $self->SUPER::get_value($instance);
26fbace8 543 }
946289d1 544}
a15dff8d 545
26fbace8 546## installing accessors
c0e30cf5 547
d617b644 548sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
d7f17ebb 549
452bac1b 550sub install_accessors {
551 my $self = shift;
26fbace8 552 $self->SUPER::install_accessors(@_);
d3e7fe85 553 $self->install_delegation if $self->has_handles;
554 return;
555}
26fbace8 556
d3e7fe85 557sub install_delegation {
558 my $self = shift;
26fbace8 559
d3e7fe85 560 # NOTE:
561 # Here we canonicalize the 'handles' option
562 # this will sort out any details and always
563 # return an hash of methods which we want
564 # to delagate to, see that method for details
330dbb07 565 my %handles = $self->_canonicalize_handles;
d3e7fe85 566
567 # find the accessor method for this attribute
330dbb07 568 my $accessor = $self->_get_delegate_accessor;
d3e7fe85 569
570 # install the delegation ...
571 my $associated_class = $self->associated_class;
572 foreach my $handle (keys %handles) {
573 my $method_to_call = $handles{$handle};
574 my $class_name = $associated_class->name;
575 my $name = "${class_name}::${handle}";
576
577 (!$associated_class->has_method($handle))
578 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
26fbace8 579
d3e7fe85 580 # NOTE:
581 # handles is not allowed to delegate
582 # any of these methods, as they will
583 # override the ones in your class, which
584 # is almost certainly not what you want.
4fe78472 585
d3e7fe85 586 # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
587 #cluck("Not delegating method '$handle' because it is a core method") and
588 next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
26fbace8 589
d3e7fe85 590 if ('CODE' eq ref($method_to_call)) {
591 $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
452bac1b 592 }
d3e7fe85 593 else {
594 # NOTE:
595 # we used to do a goto here, but the
596 # goto didn't handle failure correctly
597 # (it just returned nothing), so I took
598 # that out. However, the more I thought
599 # about it, the less I liked it doing
600 # the goto, and I prefered the act of
601 # delegation being actually represented
602 # in the stack trace.
603 # - SL
604 $associated_class->add_method($handle => Class::MOP::subname($name, sub {
605 my $proxy = (shift)->$accessor();
606 (defined $proxy)
607 || confess "Cannot delegate $handle to $method_to_call because " .
608 "the value of " . $self->name . " is not defined";
609 $proxy->$method_to_call(@_);
610 }));
611 }
612 }
452bac1b 613}
614
98aae381 615# private methods to help delegation ...
616
330dbb07 617sub _get_delegate_accessor {
618 my $self = shift;
619 # find the accessor method for this attribute
620 my $accessor = $self->get_read_method_ref;
621 # then unpack it if we need too ...
622 $accessor = $accessor->body if blessed $accessor;
623 # return the accessor
624 return $accessor;
625}
626
452bac1b 627sub _canonicalize_handles {
628 my $self = shift;
629 my $handles = $self->handles;
c84f324f 630 if (my $handle_type = ref($handles)) {
631 if ($handle_type eq 'HASH') {
632 return %{$handles};
633 }
634 elsif ($handle_type eq 'ARRAY') {
635 return map { $_ => $_ } @{$handles};
636 }
637 elsif ($handle_type eq 'Regexp') {
638 ($self->has_type_constraint)
639 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
26fbace8 640 return map { ($_ => $_) }
c84f324f 641 grep { /$handles/ } $self->_get_delegate_method_list;
642 }
643 elsif ($handle_type eq 'CODE') {
644 return $handles->($self, $self->_find_delegate_metaclass);
645 }
646 else {
647 confess "Unable to canonicalize the 'handles' option with $handles";
648 }
452bac1b 649 }
650 else {
c84f324f 651 my $role_meta = eval { $handles->meta };
652 if ($@) {
26fbace8 653 confess "Unable to canonicalize the 'handles' option with $handles because : $@";
c84f324f 654 }
655
656 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
657 || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
26fbace8 658
c84f324f 659 return map { $_ => $_ } (
26fbace8 660 $role_meta->get_method_list,
c84f324f 661 $role_meta->get_required_method_list
662 );
452bac1b 663 }
664}
665
666sub _find_delegate_metaclass {
667 my $self = shift;
98aae381 668 if (my $class = $self->_isa_metadata) {
26fbace8 669 # if the class does have
452bac1b 670 # a meta method, use it
671 return $class->meta if $class->can('meta');
26fbace8 672 # otherwise we might be
452bac1b 673 # dealing with a non-Moose
26fbace8 674 # class, and need to make
452bac1b 675 # our own metaclass
676 return Moose::Meta::Class->initialize($class);
677 }
98aae381 678 elsif (my $role = $self->_does_metadata) {
26fbace8 679 # our role will always have
452bac1b 680 # a meta method
98aae381 681 return $role->meta;
452bac1b 682 }
683 else {
684 confess "Cannot find delegate metaclass for attribute " . $self->name;
685 }
686}
687
688sub _get_delegate_method_list {
689 my $self = shift;
690 my $meta = $self->_find_delegate_metaclass;
691 if ($meta->isa('Class::MOP::Class')) {
3b82ee4f 692 return map { $_->name } # NOTE: !never! delegate &meta
693 grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
694 $meta->get_all_methods;
452bac1b 695 }
696 elsif ($meta->isa('Moose::Meta::Role')) {
26fbace8 697 return $meta->get_method_list;
452bac1b 698 }
699 else {
700 confess "Unable to recognize the delegate metaclass '$meta'";
701 }
702}
703
21f1e231 704package Moose::Meta::Attribute::Custom::Moose;
705sub register_implementation { 'Moose::Meta::Attribute' }
706
c0e30cf5 7071;
708
709__END__
710
711=pod
712
713=head1 NAME
714
6ba6d68c 715Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5 716
717=head1 DESCRIPTION
718
26fbace8 719This is a subclass of L<Class::MOP::Attribute> with Moose specific
720extensions.
6ba6d68c 721
26fbace8 722For the most part, the only time you will ever encounter an
723instance of this class is if you are doing some serious deep
724introspection. To really understand this class, you need to refer
6ba6d68c 725to the L<Class::MOP::Attribute> documentation.
e522431d 726
c0e30cf5 727=head1 METHODS
728
6ba6d68c 729=head2 Overridden methods
730
26fbace8 731These methods override methods in L<Class::MOP::Attribute> and add
732Moose specific features. You can safely assume though that they
6ba6d68c 733will behave just as L<Class::MOP::Attribute> does.
734
c0e30cf5 735=over 4
736
737=item B<new>
738
c32c2c61 739=item B<clone>
740
6e2840b7 741=item B<does>
742
d500266f 743=item B<initialize_instance_slot>
744
452bac1b 745=item B<install_accessors>
746
d3e7fe85 747=item B<install_delegation>
748
39b3bc94 749=item B<accessor_metaclass>
750
946289d1 751=item B<get_value>
752
753=item B<set_value>
754
bcbaa845 755 eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
756 if($@) {
757 print "Oops: $@\n";
758 }
759
760I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
761
762Before setting the value, a check is made on the type constraint of
763the attribute, if it has one, to see if the value passes it. If the
764value fails to pass, the set operation dies with a L<Carp/confess>.
765
766Any coercion to convert values is done before checking the type constraint.
767
768To check a value against a type constraint before setting it, fetch the
ec00fa75 769attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
bcbaa845 770fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
5cfe3805 771and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
bcbaa845 772for an example.
773
a15dff8d 774=back
775
6ba6d68c 776=head2 Additional Moose features
777
26fbace8 778Moose attributes support type-constraint checking, weak reference
779creation and type coercion.
6ba6d68c 780
a15dff8d 781=over 4
782
d5c30e52 783=item B<interpolate_class_and_new>
784
785=item B<interpolate_class>
786
787When called as a class method causes interpretation of the C<metaclass> and
788C<traits> options.
789
9e93dd19 790=item B<clone_and_inherit_options>
791
26fbace8 792This is to support the C<has '+foo'> feature, it clones an attribute
793from a superclass and allows a very specific set of changes to be made
9e93dd19 794to the attribute.
795
aa08864c 796=item B<legal_options_for_inheritance>
797
798Whitelist with options you can change. You can overload it in your custom
799metaclass to allow your options be inheritable.
800
a15dff8d 801=item B<has_type_constraint>
802
6ba6d68c 803Returns true if this meta-attribute has a type constraint.
804
a15dff8d 805=item B<type_constraint>
806
26fbace8 807A read-only accessor for this meta-attribute's type constraint. For
808more information on what you can do with this, see the documentation
6ba6d68c 809for L<Moose::Meta::TypeConstraint>.
a15dff8d 810
452bac1b 811=item B<has_handles>
812
813Returns true if this meta-attribute performs delegation.
814
815=item B<handles>
816
817This returns the value which was passed into the handles option.
818
6ba6d68c 819=item B<is_weak_ref>
a15dff8d 820
02a0fb52 821Returns true if this meta-attribute produces a weak reference.
4b598ea3 822
ca01a97b 823=item B<is_required>
824
02a0fb52 825Returns true if this meta-attribute is required to have a value.
ca01a97b 826
827=item B<is_lazy>
828
02a0fb52 829Returns true if this meta-attribute should be initialized lazily.
ca01a97b 830
26fbace8 831NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
832
833=item B<is_lazy_build>
834
835Returns true if this meta-attribute should be initialized lazily through
836the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
837make your attribute required and lazy. In addition it will set the builder, clearer
838and predicate options for you using the following convention.
839
840 #If your attribute name starts with an underscore:
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});
26fbace8 846
847 #If your attribute name does not start with an underscore:
58f85113 848 has 'foo' => (lazy_build => 1);
849 #is the same as
4c9e0478 850 has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo');
26fbace8 851 # or
58f85113 852 has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
853
854The reason for the different naming of the C<builder> is that the C<builder>
855method is a private method while the C<clearer> and C<predicate> methods
856are public methods.
26fbace8 857
858NOTE: This means your class should provide a method whose name matches the value
58f85113 859of the builder part, in this case _build__foo or _build_foo.
ca01a97b 860
34a66aa3 861=item B<should_coerce>
4b598ea3 862
02a0fb52 863Returns true if this meta-attribute should perform type coercion.
6ba6d68c 864
536f0b17 865=item B<should_auto_deref>
866
26fbace8 867Returns true if this meta-attribute should perform automatic
868auto-dereferencing.
536f0b17 869
26fbace8 870NOTE: This can only be done for attributes whose type constraint is
536f0b17 871either I<ArrayRef> or I<HashRef>.
872
8c9d74e7 873=item B<has_trigger>
874
02a0fb52 875Returns true if this meta-attribute has a trigger set.
876
8c9d74e7 877=item B<trigger>
878
26fbace8 879This is a CODE reference which will be executed every time the
880value of an attribute is assigned. The CODE ref will get two values,
881the invocant and the new value. This can be used to handle I<basic>
02a0fb52 882bi-directional relations.
883
ddbdc0cb 884=item B<documentation>
885
26fbace8 886This is a string which contains the documentation for this attribute.
ddbdc0cb 887It serves no direct purpose right now, but it might in the future
888in some kind of automated documentation system perhaps.
889
890=item B<has_documentation>
891
892Returns true if this meta-attribute has any documentation.
893
88f23977 894=item B<applied_traits>
895
896This will return the ARRAY ref of all the traits applied to this
897attribute, or if no traits have been applied, it returns C<undef>.
898
899=item B<has_applied_traits>
900
901Returns true if this meta-attribute has any traits applied.
902
c0e30cf5 903=back
904
905=head1 BUGS
906
26fbace8 907All complex software has bugs lurking in it, and this module is no
c0e30cf5 908exception. If you find a bug please either email me, or add the bug
909to cpan-RT.
910
c0e30cf5 911=head1 AUTHOR
912
913Stevan Little E<lt>stevan@iinteractive.comE<gt>
914
98aae381 915Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
916
c0e30cf5 917=head1 COPYRIGHT AND LICENSE
918
778db3ac 919Copyright 2006-2008 by Infinity Interactive, Inc.
c0e30cf5 920
921L<http://www.iinteractive.com>
922
923This library is free software; you can redistribute it and/or modify
26fbace8 924it under the same terms as Perl itself.
c0e30cf5 925
8a7a9c53 926=cut