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