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