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