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