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