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