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