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