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