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