lib/Moose/Meta/Attribute.pm

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