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