Use Class::MOP::get_meta($thing) instead of $thing->meta
[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
bda8d00f 252 foreach my $attr ( grep { $_->has_value($self) } Class::MOP::get_meta($self)->compute_all_applicable_attributes ) {
c32c2c61 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
bda8d00f 654 my $role_meta = Class::MOP::get_meta($handles);
c84f324f 655
656 (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
bda8d00f 657 || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass 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
bda8d00f 671 my $meta = Class::MOP::get_meta($class);
672 return $meta if $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
bda8d00f 682 return Class::MOP::get_meta($role);
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
5755a9b2 721sub verify_against_type_constraint {
2b86e02b 722 my $self = shift;
723 my $val = shift;
724
725 return 1 if !$self->has_type_constraint;
726
727 my $type_constraint = $self->type_constraint;
728
729 $type_constraint->check($val)
730 || $self->throw_error("Attribute ("
731 . $self->name
732 . ") does not pass the type constraint because: "
733 . $type_constraint->get_message($val), data => $val, @_);
734}
735
21f1e231 736package Moose::Meta::Attribute::Custom::Moose;
737sub register_implementation { 'Moose::Meta::Attribute' }
738
c0e30cf5 7391;
740
741__END__
742
743=pod
744
745=head1 NAME
746
6ba6d68c 747Moose::Meta::Attribute - The Moose attribute metaclass
c0e30cf5 748
749=head1 DESCRIPTION
750
26fbace8 751This is a subclass of L<Class::MOP::Attribute> with Moose specific
752extensions.
6ba6d68c 753
26fbace8 754For the most part, the only time you will ever encounter an
755instance of this class is if you are doing some serious deep
756introspection. To really understand this class, you need to refer
6ba6d68c 757to the L<Class::MOP::Attribute> documentation.
e522431d 758
c0e30cf5 759=head1 METHODS
760
6ba6d68c 761=head2 Overridden methods
762
26fbace8 763These methods override methods in L<Class::MOP::Attribute> and add
764Moose specific features. You can safely assume though that they
6ba6d68c 765will behave just as L<Class::MOP::Attribute> does.
766
c0e30cf5 767=over 4
768
769=item B<new>
770
c32c2c61 771=item B<clone>
772
6e2840b7 773=item B<does>
774
d500266f 775=item B<initialize_instance_slot>
776
452bac1b 777=item B<install_accessors>
778
e1d6f0a3 779=item B<remove_accessors>
780
e606ae5f 781=item B<install_delegation>
782
e1d6f0a3 783=item B<remove_delegation>
784
39b3bc94 785=item B<accessor_metaclass>
786
946289d1 787=item B<get_value>
788
789=item B<set_value>
790
bcbaa845 791 eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
792 if($@) {
793 print "Oops: $@\n";
794 }
795
796I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
797
798Before setting the value, a check is made on the type constraint of
799the attribute, if it has one, to see if the value passes it. If the
46cb090f 800value fails to pass, the set operation dies with a L<throw_error>.
bcbaa845 801
802Any coercion to convert values is done before checking the type constraint.
803
804To check a value against a type constraint before setting it, fetch the
ec00fa75 805attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
bcbaa845 806fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
e606ae5f 807and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
bcbaa845 808for an example.
809
a15dff8d 810=back
811
6ba6d68c 812=head2 Additional Moose features
813
26fbace8 814Moose attributes support type-constraint checking, weak reference
815creation and type coercion.
6ba6d68c 816
a15dff8d 817=over 4
818
be05faea 819=item B<throw_error>
820
821Delegates to C<associated_class> or C<Moose::Meta::Class> if there is none.
822
d5c30e52 823=item B<interpolate_class_and_new>
824
825=item B<interpolate_class>
826
827When called as a class method causes interpretation of the C<metaclass> and
828C<traits> options.
829
9e93dd19 830=item B<clone_and_inherit_options>
831
26fbace8 832This is to support the C<has '+foo'> feature, it clones an attribute
833from a superclass and allows a very specific set of changes to be made
9e93dd19 834to the attribute.
835
e606ae5f 836=item B<legal_options_for_inheritance>
837
838Whitelist with options you can change. You can overload it in your custom
839metaclass to allow your options be inheritable.
840
a15dff8d 841=item B<has_type_constraint>
842
6ba6d68c 843Returns true if this meta-attribute has a type constraint.
844
a15dff8d 845=item B<type_constraint>
846
26fbace8 847A read-only accessor for this meta-attribute's type constraint. For
848more information on what you can do with this, see the documentation
6ba6d68c 849for L<Moose::Meta::TypeConstraint>.
a15dff8d 850
5755a9b2 851=item B<verify_against_type_constraint>
2b86e02b 852
43cb5dad 853Verifies that the given value is valid under this attribute's type
2b86e02b 854constraint, otherwise throws an error.
855
452bac1b 856=item B<has_handles>
857
858Returns true if this meta-attribute performs delegation.
859
860=item B<handles>
861
862This returns the value which was passed into the handles option.
863
6ba6d68c 864=item B<is_weak_ref>
a15dff8d 865
02a0fb52 866Returns true if this meta-attribute produces a weak reference.
4b598ea3 867
ca01a97b 868=item B<is_required>
869
02a0fb52 870Returns true if this meta-attribute is required to have a value.
ca01a97b 871
872=item B<is_lazy>
873
02a0fb52 874Returns true if this meta-attribute should be initialized lazily.
ca01a97b 875
26fbace8 876NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
877
878=item B<is_lazy_build>
879
880Returns true if this meta-attribute should be initialized lazily through
881the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
882make your attribute required and lazy. In addition it will set the builder, clearer
883and predicate options for you using the following convention.
884
885 #If your attribute name starts with an underscore:
886 has '_foo' => (lazy_build => 1);
887 #is the same as
e606ae5f 888 has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo');
26fbace8 889 # or
58f85113 890 has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
26fbace8 891
892 #If your attribute name does not start with an underscore:
58f85113 893 has 'foo' => (lazy_build => 1);
894 #is the same as
e606ae5f 895 has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo');
26fbace8 896 # or
58f85113 897 has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
898
899The reason for the different naming of the C<builder> is that the C<builder>
900method is a private method while the C<clearer> and C<predicate> methods
901are public methods.
26fbace8 902
903NOTE: This means your class should provide a method whose name matches the value
58f85113 904of the builder part, in this case _build__foo or _build_foo.
ca01a97b 905
34a66aa3 906=item B<should_coerce>
4b598ea3 907
02a0fb52 908Returns true if this meta-attribute should perform type coercion.
6ba6d68c 909
536f0b17 910=item B<should_auto_deref>
911
26fbace8 912Returns true if this meta-attribute should perform automatic
913auto-dereferencing.
536f0b17 914
26fbace8 915NOTE: This can only be done for attributes whose type constraint is
536f0b17 916either I<ArrayRef> or I<HashRef>.
917
8c9d74e7 918=item B<has_trigger>
919
02a0fb52 920Returns true if this meta-attribute has a trigger set.
921
8c9d74e7 922=item B<trigger>
923
26fbace8 924This is a CODE reference which will be executed every time the
925value of an attribute is assigned. The CODE ref will get two values,
926the invocant and the new value. This can be used to handle I<basic>
02a0fb52 927bi-directional relations.
928
ddbdc0cb 929=item B<documentation>
930
26fbace8 931This is a string which contains the documentation for this attribute.
ddbdc0cb 932It serves no direct purpose right now, but it might in the future
933in some kind of automated documentation system perhaps.
934
935=item B<has_documentation>
936
937Returns true if this meta-attribute has any documentation.
938
88f23977 939=item B<applied_traits>
940
941This will return the ARRAY ref of all the traits applied to this
942attribute, or if no traits have been applied, it returns C<undef>.
943
944=item B<has_applied_traits>
945
946Returns true if this meta-attribute has any traits applied.
947
c0e30cf5 948=back
949
950=head1 BUGS
951
26fbace8 952All complex software has bugs lurking in it, and this module is no
c0e30cf5 953exception. If you find a bug please either email me, or add the bug
954to cpan-RT.
955
c0e30cf5 956=head1 AUTHOR
957
958Stevan Little E<lt>stevan@iinteractive.comE<gt>
959
98aae381 960Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
961
c0e30cf5 962=head1 COPYRIGHT AND LICENSE
963
778db3ac 964Copyright 2006-2008 by Infinity Interactive, Inc.
c0e30cf5 965
966L<http://www.iinteractive.com>
967
968This library is free software; you can redistribute it and/or modify
26fbace8 969it under the same terms as Perl itself.
c0e30cf5 970
8a7a9c53 971=cut