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.73';
  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     lazy_build
 150 );
 151
 152 sub legal_options_for_inheritance { @legal_options_for_inheritance }
 153
 154 # NOTE/TODO
 155 # This method *must* be able to handle
 156 # Class::MOP::Attribute instances as
 157 # well. Yes, I know that is wrong, but
 158 # apparently we didn't realize it was
 159 # doing that and now we have some code
 160 # which is dependent on it. The real
 161 # solution of course is to push this
 162 # feature back up into Class::MOP::Attribute
 163 # but I not right now, I am too lazy.
 164 # However if you are reading this and
 165 # looking for something to do,.. please
 166 # be my guest.
 167 # - stevan
 168 sub clone_and_inherit_options {
 169     my ($self, %options) = @_;
 170
 171     my %copy = %options;
 172
 173     my %actual_options;
 174
 175     # NOTE:
 176     # we may want to extends a Class::MOP::Attribute
 177     # in which case we need to be able to use the
 178     # core set of legal options that have always
 179     # been here. But we allows Moose::Meta::Attribute
 180     # instances to changes them.
 181     # - SL
 182     my @legal_options = $self->can('legal_options_for_inheritance')
 183         ? $self->legal_options_for_inheritance
 184         : @legal_options_for_inheritance;
 185
 186     foreach my $legal_option (@legal_options) {
 187         if (exists $options{$legal_option}) {
 188             $actual_options{$legal_option} = $options{$legal_option};
 189             delete $options{$legal_option};
 190         }
 191     }
 192
 193     if ($options{isa}) {
 194         my $type_constraint;
 195         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
 196             $type_constraint = $options{isa};
 197         }
 198         else {
 199             $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
 200             (defined $type_constraint)
 201                 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
 202         }
 203
 204         $actual_options{type_constraint} = $type_constraint;
 205         delete $options{isa};
 206     }
 207
 208     if ($options{does}) {
 209         my $type_constraint;
 210         if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
 211             $type_constraint = $options{does};
 212         }
 213         else {
 214             $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
 215             (defined $type_constraint)
 216                 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
 217         }
 218
 219         $actual_options{type_constraint} = $type_constraint;
 220         delete $options{does};
 221     }
 222
 223     # NOTE:
 224     # this doesn't apply to Class::MOP::Attributes,
 225     # so we can ignore it for them.
 226     # - SL
 227     if ($self->can('interpolate_class')) {
 228         ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(%options);
 229
 230         my %seen;
 231         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
 232         $actual_options{traits} = \@all_traits if @all_traits;
 233
 234         delete @options{qw(metaclass traits)};
 235     }
 236
 237     (scalar keys %options == 0)
 238         || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options);
 239
 240
 241     $self->clone(%actual_options);
 242 }
 243
 244 sub clone {
 245     my ( $self, %params ) = @_;
 246
 247     my $class = $params{metaclass} || ref $self;
 248
 249     my ( @init, @non_init );
 250
 251     foreach my $attr ( grep { $_->has_value($self) } $self->meta->compute_all_applicable_attributes ) {
 252         push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
 253     }
 254
 255     my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
 256
 257     my $name = delete $new_params{name};
 258
 259     my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
 260
 261     foreach my $attr ( @non_init ) {
 262         $attr->set_value($clone, $attr->get_value($self));
 263     }
 264
 265     return $clone;
 266 }
 267
 268 sub _process_options {
 269     my ($class, $name, $options) = @_;
 270
 271     if (exists $options->{is}) {
 272
 273         ### -------------------------
 274         ## is => ro, writer => _foo    # turns into (reader => foo, writer => _foo) as before
 275         ## is => rw, writer => _foo    # turns into (reader => foo, writer => _foo)
 276         ## is => rw, accessor => _foo  # turns into (accessor => _foo)
 277         ## is => ro, accessor => _foo  # error, accesor is rw
 278         ### -------------------------
 279
 280         if ($options->{is} eq 'ro') {
 281             $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
 282                 if exists $options->{accessor};
 283             $options->{reader} ||= $name;
 284         }
 285         elsif ($options->{is} eq 'rw') {
 286             if ($options->{writer}) {
 287                 $options->{reader} ||= $name;
 288             }
 289             else {
 290                 $options->{accessor} ||= $name;
 291             }
 292         }
 293         else {
 294             $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
 295         }
 296     }
 297
 298     if (exists $options->{isa}) {
 299         if (exists $options->{does}) {
 300             if (eval { $options->{isa}->can('does') }) {
 301                 ($options->{isa}->does($options->{does}))
 302                     || $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);
 303             }
 304             else {
 305                 $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
 306             }
 307         }
 308
 309         # allow for anon-subtypes here ...
 310         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 311             $options->{type_constraint} = $options->{isa};
 312         }
 313         else {
 314             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
 315         }
 316     }
 317     elsif (exists $options->{does}) {
 318         # allow for anon-subtypes here ...
 319         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 320                 $options->{type_constraint} = $options->{does};
 321         }
 322         else {
 323             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
 324         }
 325     }
 326
 327     if (exists $options->{coerce} && $options->{coerce}) {
 328         (exists $options->{type_constraint})
 329             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options);
 330         $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options)
 331             if $options->{weak_ref};
 332     }
 333
 334     if (exists $options->{trigger}) {
 335         ('CODE' eq ref $options->{trigger})
 336             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
 337     }
 338
 339     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 340         (exists $options->{type_constraint})
 341             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options);
 342         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 343          $options->{type_constraint}->is_a_type_of('HashRef'))
 344             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options);
 345     }
 346
 347     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
 348         $class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options)
 349             if exists $options->{default};
 350         $options->{lazy}      = 1;
 351         $options->{required}  = 1;
 352         $options->{builder} ||= "_build_${name}";
 353         if ($name =~ /^_/) {
 354             $options->{clearer}   ||= "_clear${name}";
 355             $options->{predicate} ||= "_has${name}";
 356         }
 357         else {
 358             $options->{clearer}   ||= "clear_${name}";
 359             $options->{predicate} ||= "has_${name}";
 360         }
 361     }
 362
 363     if (exists $options->{lazy} && $options->{lazy}) {
 364         (exists $options->{default} || defined $options->{builder} )
 365             || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
 366     }
 367
 368     if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
 369         $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
 370     }
 371
 372 }
 373
 374 sub initialize_instance_slot {
 375     my ($self, $meta_instance, $instance, $params) = @_;
 376     my $init_arg = $self->init_arg();
 377     # try to fetch the init arg from the %params ...
 378
 379     my $val;
 380     my $value_is_set;
 381     if ( defined($init_arg) and exists $params->{$init_arg}) {
 382         $val = $params->{$init_arg};
 383         $value_is_set = 1;
 384     }
 385     else {
 386         # skip it if it's lazy
 387         return if $self->is_lazy;
 388         # and die if it's required and doesn't have a default value
 389         $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
 390             if $self->is_required && !$self->has_default && !$self->has_builder;
 391
 392         # if nothing was in the %params, we can use the
 393         # attribute's default value (if it has one)
 394         if ($self->has_default) {
 395             $val = $self->default($instance);
 396             $value_is_set = 1;
 397         }
 398         elsif ($self->has_builder) {
 399             $val = $self->_call_builder($instance);
 400             $value_is_set = 1;
 401         }
 402     }
 403
 404     return unless $value_is_set;
 405
 406     if ($self->has_type_constraint) {
 407         my $type_constraint = $self->type_constraint;
 408         if ($self->should_coerce && $type_constraint->has_coercion) {
 409             $val = $type_constraint->coerce($val);
 410         }
 411         $self->verify_against_type_constraint($val, instance => $instance);
 412     }
 413
 414     $self->set_initial_value($instance, $val);
 415     $meta_instance->weaken_slot_value($instance, $self->name)
 416         if ref $val && $self->is_weak_ref;
 417 }
 418
 419 sub _call_builder {
 420     my ( $self, $instance ) = @_;
 421
 422     my $builder = $self->builder();
 423
 424     return $instance->$builder()
 425         if $instance->can( $self->builder );
 426
 427     $self->throw_error(  blessed($instance)
 428             . " does not support builder method '"
 429             . $self->builder
 430             . "' for attribute '"
 431             . $self->name
 432             . "'",
 433             object => $instance,
 434      );
 435 }
 436
 437 ## Slot management
 438
 439 # FIXME:
 440 # this duplicates too much code from
 441 # Class::MOP::Attribute, we need to
 442 # refactor these bits eventually.
 443 # - SL
 444 sub _set_initial_slot_value {
 445     my ($self, $meta_instance, $instance, $value) = @_;
 446
 447     my $slot_name = $self->name;
 448
 449     return $meta_instance->set_slot_value($instance, $slot_name, $value)
 450         unless $self->has_initializer;
 451
 452     my ($type_constraint, $can_coerce);
 453     if ($self->has_type_constraint) {
 454         $type_constraint = $self->type_constraint;
 455         $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
 456     }
 457
 458     my $callback = sub {
 459         my $val = shift;
 460         if ($type_constraint) {
 461             $val = $type_constraint->coerce($val)
 462                 if $can_coerce;
 463             $self->verify_against_type_constraint($val, object => $instance);
 464         }
 465         $meta_instance->set_slot_value($instance, $slot_name, $val);
 466     };
 467
 468     my $initializer = $self->initializer;
 469
 470     # most things will just want to set a value, so make it first arg
 471     $instance->$initializer($value, $callback, $self);
 472 }
 473
 474 sub set_value {
 475     my ($self, $instance, @args) = @_;
 476     my $value = $args[0];
 477
 478     my $attr_name = $self->name;
 479
 480     if ($self->is_required and not @args) {
 481         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
 482     }
 483
 484     my $type_constraint = $self->type_constraint;
 485     if ($self->should_coerce && $type_constraint->has_coercion) {
 486         $value = $type_constraint->coerce($value);
 487     }
 488     $self->verify_against_type_constraint($value, instance => $instance);
 489
 490     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 491                                          ->get_meta_instance;
 492
 493     $meta_instance->set_slot_value($instance, $attr_name, $value);
 494
 495     if (ref $value && $self->is_weak_ref) {
 496         $meta_instance->weaken_slot_value($instance, $attr_name);
 497     }
 498
 499     if ($self->has_trigger) {
 500         $self->trigger->($instance, $value);
 501     }
 502 }
 503
 504 sub get_value {
 505     my ($self, $instance) = @_;
 506
 507     if ($self->is_lazy) {
 508         unless ($self->has_value($instance)) {
 509             my $value;
 510             if ($self->has_default) {
 511                 $value = $self->default($instance);
 512             } elsif ( $self->has_builder ) {
 513                 $value = $self->_call_builder($instance);
 514             }
 515             if ($self->has_type_constraint) {
 516                 my $type_constraint = $self->type_constraint;
 517                 $value = $type_constraint->coerce($value)
 518                     if ($self->should_coerce);
 519                 $self->verify_against_type_constraint($value);
 520             }
 521             $self->set_initial_value($instance, $value);
 522         }
 523     }
 524
 525     if ($self->should_auto_deref) {
 526
 527         my $type_constraint = $self->type_constraint;
 528
 529         if ($type_constraint->is_a_type_of('ArrayRef')) {
 530             my $rv = $self->SUPER::get_value($instance);
 531             return unless defined $rv;
 532             return wantarray ? @{ $rv } : $rv;
 533         }
 534         elsif ($type_constraint->is_a_type_of('HashRef')) {
 535             my $rv = $self->SUPER::get_value($instance);
 536             return unless defined $rv;
 537             return wantarray ? %{ $rv } : $rv;
 538         }
 539         else {
 540             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
 541         }
 542
 543     }
 544     else {
 545
 546         return $self->SUPER::get_value($instance);
 547     }
 548 }
 549
 550 ## installing accessors
 551
 552 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 553
 554 sub install_accessors {
 555     my $self = shift;
 556     $self->SUPER::install_accessors(@_);
 557     $self->install_delegation if $self->has_handles;
 558     return;
 559 }
 560
 561 sub remove_accessors {
 562     my $self = shift;
 563     $self->SUPER::remove_accessors(@_);
 564     $self->remove_delegation if $self->has_handles;
 565     return;
 566 }
 567
 568 sub install_delegation {
 569     my $self = shift;
 570
 571     # NOTE:
 572     # Here we canonicalize the 'handles' option
 573     # this will sort out any details and always
 574     # return an hash of methods which we want
 575     # to delagate to, see that method for details
 576     my %handles = $self->_canonicalize_handles;
 577
 578
 579     # install the delegation ...
 580     my $associated_class = $self->associated_class;
 581     foreach my $handle (keys %handles) {
 582         my $method_to_call = $handles{$handle};
 583         my $class_name = $associated_class->name;
 584         my $name = "${class_name}::${handle}";
 585
 586             (!$associated_class->has_method($handle))
 587                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 588
 589         # NOTE:
 590         # handles is not allowed to delegate
 591         # any of these methods, as they will
 592         # override the ones in your class, which
 593         # is almost certainly not what you want.
 594
 595         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 596         #cluck("Not delegating method '$handle' because it is a core method") and
 597         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 598
 599         my $method = $self->_make_delegation_method($handle, $method_to_call);
 600
 601         $self->associated_class->add_method($method->name, $method);
 602     }
 603 }
 604
 605 sub remove_delegation {
 606     my $self = shift;
 607     my %handles = $self->_canonicalize_handles;
 608     my $associated_class = $self->associated_class;
 609     foreach my $handle (keys %handles) {
 610         $self->associated_class->remove_method($handle);
 611     }
 612 }
 613
 614 # private methods to help delegation ...
 615
 616 sub _canonicalize_handles {
 617     my $self    = shift;
 618     my $handles = $self->handles;
 619     if (my $handle_type = ref($handles)) {
 620         if ($handle_type eq 'HASH') {
 621             return %{$handles};
 622         }
 623         elsif ($handle_type eq 'ARRAY') {
 624             return map { $_ => $_ } @{$handles};
 625         }
 626         elsif ($handle_type eq 'Regexp') {
 627             ($self->has_type_constraint)
 628                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 629             return map  { ($_ => $_) }
 630                    grep { /$handles/ } $self->_get_delegate_method_list;
 631         }
 632         elsif ($handle_type eq 'CODE') {
 633             return $handles->($self, $self->_find_delegate_metaclass);
 634         }
 635         else {
 636             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 637         }
 638     }
 639     else {
 640         Class::MOP::load_class($handles)
 641             unless Class::MOP::is_class_loaded($handles);
 642
 643         my $role_meta = eval { $handles->meta };
 644         if ($@) {
 645             $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@);
 646         }
 647
 648         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 649             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles);
 650
 651         return map { $_ => $_ } (
 652             $role_meta->get_method_list,
 653             $role_meta->get_required_method_list
 654         );
 655     }
 656 }
 657
 658 sub _find_delegate_metaclass {
 659     my $self = shift;
 660     if (my $class = $self->_isa_metadata) {
 661         # if the class does have
 662         # a meta method, use it
 663         return $class->meta if $class->can('meta');
 664         # otherwise we might be
 665         # dealing with a non-Moose
 666         # class, and need to make
 667         # our own metaclass
 668         return Moose::Meta::Class->initialize($class);
 669     }
 670     elsif (my $role = $self->_does_metadata) {
 671         # our role will always have
 672         # a meta method
 673         return $role->meta;
 674     }
 675     else {
 676         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 677     }
 678 }
 679
 680 sub _get_delegate_method_list {
 681     my $self = shift;
 682     my $meta = $self->_find_delegate_metaclass;
 683     if ($meta->isa('Class::MOP::Class')) {
 684         return map  { $_->name }  # NOTE: !never! delegate &meta
 685                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 686                     $meta->get_all_methods;
 687     }
 688     elsif ($meta->isa('Moose::Meta::Role')) {
 689         return $meta->get_method_list;
 690     }
 691     else {
 692         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 693     }
 694 }
 695
 696 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 697
 698 sub _make_delegation_method {
 699     my ( $self, $handle_name, $method_to_call ) = @_;
 700
 701     my $method_body;
 702
 703     $method_body = $method_to_call
 704         if 'CODE' eq ref($method_to_call);
 705
 706     return $self->delegation_metaclass->new(
 707         name               => $handle_name,
 708         package_name       => $self->associated_class->name,
 709         attribute          => $self,
 710         delegate_to_method => $method_to_call,
 711     );
 712 }
 713
 714 sub verify_against_type_constraint {
 715     my $self = shift;
 716     my $val  = shift;
 717
 718     return 1 if !$self->has_type_constraint;
 719
 720     my $type_constraint = $self->type_constraint;
 721
 722     $type_constraint->check($val)
 723         || $self->throw_error("Attribute ("
 724                  . $self->name
 725                  . ") does not pass the type constraint because: "
 726                  . $type_constraint->get_message($val), data => $val, @_);
 727 }
 728
 729 package Moose::Meta::Attribute::Custom::Moose;
 730 sub register_implementation { 'Moose::Meta::Attribute' }
 731
 732 1;
 733
 734 __END__
 735
 736 =pod
 737
 738 =head1 NAME
 739
 740 Moose::Meta::Attribute - The Moose attribute metaclass
 741
 742 =head1 DESCRIPTION
 743
 744 This class is a subclass of L<Class::MOP::Attribute> that provides
 745 additional Moose-specific functionality.
 746
 747 To really understand this class, you will need to start with the
 748 L<Class::MOP::Attribute> documentation. This class can be understood
 749 as a set of additional features on top of the basic feature provided
 750 by that parent class.
 751
 752 =head1 INHERITANCE
 753
 754 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 755
 756 =head1 METHODS
 757
 758 Many of the documented below override methods in
 759 L<Class::MOP::Attribute> and add Moose specific features.
 760
 761 =head2 Creation
 762
 763 =over 4
 764
 765 =item B<< Moose::Meta::Attribute->new(%options) >>
 766
 767 This method overrides the L<Class::MOP::Attribute> constructor.
 768
 769 Many of the options below are described in more detail in the
 770 L<Moose::Manual::Attributes> document.
 771
 772 It adds the following options to the constructor:
 773
 774 =over 8
 775
 776 =item * is => 'ro' or 'rw'
 777
 778 This provides a shorthand for specifying the C<reader>, C<writer>, or
 779 C<accessor> names. If the attribute is read-only ('ro') then it will
 780 have a C<reader> method with the same attribute as the name.
 781
 782 If it is read-write ('rw') then it will have an C<accessor> method
 783 with the same name. If you provide an explicit C<writer> for a
 784 read-write attribute, then you will have a C<reader> with the same
 785 name as the attribute, and a C<writer> with the name you provided.
 786
 787 =item * isa => $type
 788
 789 This option accepts a type. The type can be a string, which should be
 790 a type name. If the type name is unknown, it is assumed to be a class
 791 name.
 792
 793 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 794
 795 If you I<also> provide a C<does> option, then your C<isa> option must
 796 be a class name, and that class must do the role specified with
 797 C<does>.
 798
 799 =item * does => $role
 800
 801 This is short-hand for saying that the attribute's type must be an
 802 object which does the named role.
 803
 804 =item * coerce => $bool
 805
 806 This option is only valid for objects with a type constraint
 807 (C<isa>). If this is true, then coercions will be applied whenever
 808 this attribute is set.
 809
 810 You can make both this and the C<weak_ref> option true.
 811
 812 =item * trigger => $sub
 813
 814 This option accepts a subroutine reference, which will be called after
 815 the attribute is set.
 816
 817 =item * required => $bool
 818
 819 An attribute which is required must be provided to the constructor. An
 820 attribute which is required can also have a C<default> or C<builder>,
 821 which will satisfy its required-ness.
 822
 823 A required attribute must have a C<default>, C<builder> or a
 824 non-C<undef> C<init_arg>
 825
 826 =item * lazy => $bool
 827
 828 A lazy attribute must have a C<default> or C<builder>. When an
 829 attribute is lazy, the default value will not be calculated until the
 830 attribute is read.
 831
 832 =item * weak_ref => $bool
 833
 834 If this is true, the attribute's value will be stored as a weak
 835 reference.
 836
 837 =item * auto_deref => $bool
 838
 839 If this is true, then the reader will dereference the value when it is
 840 called. The attribute must have a type constraint which defines the
 841 attribute as an array or hash reference.
 842
 843 =item * lazy_build => $bool
 844
 845 Setting this to true makes the attribute lazy and provides a number of
 846 default methods.
 847
 848   has 'size' => (
 849       is         => 'ro',
 850       lazy_build => 1,
 851   );
 852
 853 is equivalent to this:
 854
 855   has 'size' => (
 856       is        => 'ro',
 857       lazy      => 1,
 858       builder   => '_build_size',
 859       clearer   => 'clear_size',
 860       predicate => 'has_size',
 861   );
 862
 863 =item * documentation
 864
 865 An arbitrary string that can be retrieved later by calling C<<
 866 $attr->documentation >>.
 867
 868 =back
 869
 870 =item B<< $attr->clone(%options) >>
 871
 872 This creates a new attribute based on attribute being cloned. You must
 873 supply a C<name> option to provide a new name for the attribute.
 874
 875 The C<%options> can only specify options handled by
 876 L<Class::MOP::Attribute>.
 877
 878 =back
 879
 880 =head2 Value management
 881
 882 =over 4
 883
 884 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 885
 886 This method is used internally to initialize the attribute's slot in
 887 the object C<$instance>.
 888
 889 This overrides the L<Class::MOP::Attribute> method to handle lazy
 890 attributes, weak references, and type constraints.
 891
 892 =item B<get_value>
 893
 894 =item B<set_value>
 895
 896   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 897   if($@) {
 898     print "Oops: $@\n";
 899   }
 900
 901 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 902
 903 Before setting the value, a check is made on the type constraint of
 904 the attribute, if it has one, to see if the value passes it. If the
 905 value fails to pass, the set operation dies with a L<throw_error>.
 906
 907 Any coercion to convert values is done before checking the type constraint.
 908
 909 To check a value against a type constraint before setting it, fetch the
 910 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 911 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 912 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 913 for an example.
 914
 915 =back
 916
 917 =head2 Attribute Accessor generation
 918
 919 =over 4
 920
 921 =item B<< $attr->install_accessors >>
 922
 923 This method overrides the parent to also install delegation methods.
 924
 925 =item B<< $attr->remove_accessors >>
 926
 927 This method overrides the parent to also remove delegation methods.
 928
 929 =item B<< $attr->install_delegation >>
 930
 931 This method adds its delegation methods to the attribute's associated
 932 class, if it has any to add.
 933
 934 =item B<< $attr->remove_delegation >>
 935
 936 This method remove its delegation methods from the attribute's
 937 associated class.
 938
 939 =item B<< $attr->accessor_metaclass >>
 940
 941 Returns the accessor metaclass name, which defaults to
 942 L<Moose::Meta::Method::Accessor>.
 943
 944 =item B<< $attr->delegation_metaclass >>
 945
 946 Returns the delegation metaclass name, which defaults to
 947 L<Moose::Meta::Method::Delegation>.
 948
 949 =back
 950
 951 =head2 Additional Moose features
 952
 953 These methods are not found in the superclass. They support features
 954 provided by Moose.
 955
 956 =over 4
 957
 958 =item B<< $attr->does($role) >>
 959
 960 This indicates whether the I<attribute itself> does the given
 961 role. The role can be given as a full class name, or as a resolvable
 962 trait name.
 963
 964 Note that this checks the attribute itself, not its type constraint,
 965 so it is checking the attribute's metaclass and any traits applied to
 966 the attribute.
 967
 968 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
 969
 970 This is an alternate constructor that handles the C<metaclass> and
 971 C<traits> options.
 972
 973 Effectively, this method is a factory that finds or creates the
 974 appropriate class for the given C<metaclass> and/or C<traits>.
 975
 976 Once it has the appropriate class, it will call C<< $class->new($name,
 977 %options) >> on that class.
 978
 979 =item B<< $attr->clone_and_inherit_options(%options) >>
 980
 981 This method supports the C<has '+foo'> feature. It does various bits
 982 of processing on the supplied C<%options> before ultimately calling
 983 the C<clone> method.
 984
 985 One of its main tasks is to make sure that the C<%options> provided
 986 only includes the options returned by the
 987 C<legal_options_for_inheritance> method.
 988
 989 =item B<< $attr->legal_options_for_inheritance >>
 990
 991 This returns a whitelist of options that can be overridden in a
 992 subclass's attribute definition.
 993
 994 This exists to allow a custom metaclass to change or add to the list
 995 of options which can be changed.
 996
 997 =item B<< $attr->type_constraint >>
 998
 999 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1000 if it has one.
1001
1002 =item B<< $attr->has_type_constraint >>
1003
1004 Returns true if this attribute has a type constraint.
1005
1006 =item B<< $attr->verify_against_type_constraint($value) >>
1007
1008 Given a value, this method returns true if the value is valid for the
1009 attribute's type constraint. If the value is not valid, it throws an
1010 error.
1011
1012 =item B<< $attr->handles >>
1013
1014 This returns the value of the C<handles> option passed to the
1015 constructor.
1016
1017 =item B<< $attr->has_handles >>
1018
1019 Returns true if this attribute performs delegation.
1020
1021 =item B<< $attr->is_weak_ref >>
1022
1023 Returns true if this attribute stores its value as a weak reference.
1024
1025 =item B<< $attr->is_required >>
1026
1027 Returns true if this attribute is required to have a value.
1028
1029 =item B<< $attr->is_lazy >>
1030
1031 Returns true if this attribute is lazy.
1032
1033 =item B<< $attr->is_lazy_build >>
1034
1035 Returns true if the C<lazy_build> option was true when passed to the
1036 constructor.
1037
1038 =item B<< $attr->should_coerce >>
1039
1040 Returns true if the C<coerce> option passed to the constructor was
1041 true.
1042
1043 =item B<< $attr->should_auto_deref >>
1044
1045 Returns true if the C<auto_deref> option passed to the constructor was
1046 true.
1047
1048 =item B<< $attr->trigger >>
1049
1050 This is the subroutine reference that was in the C<trigger> option
1051 passed to the constructor, if any.
1052
1053 =item B<< $attr->has_trigger >>
1054
1055 Returns true if this attribute has a trigger set.
1056
1057 =item B<< $attr->documentation >>
1058
1059 Returns the value that was in the C<documentation> option passed to
1060 the constructor, if any.
1061
1062 =item B<< $attr->has_documentation >>
1063
1064 Returns true if this attribute has any documentation.
1065
1066 =item B<< $attr->applied_traits >>
1067
1068 This returns an array reference of all the traits which were applied
1069 to this attribute. If none were applied, this returns C<undef>.
1070
1071 =item B<< $attr->has_applied_traits >>
1072
1073 Returns true if this attribute has any traits applied.
1074
1075 =back
1076
1077 =head1 BUGS
1078
1079 All complex software has bugs lurking in it, and this module is no
1080 exception. If you find a bug please either email me, or add the bug
1081 to cpan-RT.
1082
1083 =head1 AUTHOR
1084
1085 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1086
1087 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1088
1089 =head1 COPYRIGHT AND LICENSE
1090
1091 Copyright 2006-2009 by Infinity Interactive, Inc.
1092
1093 L<http://www.iinteractive.com>
1094
1095 This library is free software; you can redistribute it and/or modify
1096 it under the same terms as Perl itself.
1097
1098 =cut