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