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