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 accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 538
 539 sub install_accessors {
 540     my $self = shift;
 541     $self->SUPER::install_accessors(@_);
 542     $self->install_delegation if $self->has_handles;
 543     unless (
 544         @{ $self->associated_methods }
 545         || ($self->_is_metadata || '') eq 'bare'
 546     ) {
 547         Carp::cluck(
 548             'Attribute (' . $self->name . ') has no associated methods'
 549             . ' (did you mean to provide an "is" argument?)'
 550             . "\n"
 551         )
 552     }
 553     return;
 554 }
 555
 556 sub _process_accessors {
 557     my $self = shift;
 558     my ($type, $accessor, $generate_as_inline_methods) = @_;
 559     $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH';
 560     if ($self->associated_class->has_method($accessor)
 561      && !$self->associated_class->get_method($accessor)->isa('Class::MOP::Method::Accessor')) {
 562         Carp::cluck(
 563             "You cannot overwrite a locally defined method ($accessor) with "
 564           . "an accessor"
 565         );
 566     }
 567     $self->SUPER::_process_accessors(@_);
 568 }
 569
 570 sub remove_accessors {
 571     my $self = shift;
 572     $self->SUPER::remove_accessors(@_);
 573     $self->remove_delegation if $self->has_handles;
 574     return;
 575 }
 576
 577 sub install_delegation {
 578     my $self = shift;
 579
 580     # NOTE:
 581     # Here we canonicalize the 'handles' option
 582     # this will sort out any details and always
 583     # return an hash of methods which we want
 584     # to delagate to, see that method for details
 585     my %handles = $self->_canonicalize_handles;
 586
 587
 588     # install the delegation ...
 589     my $associated_class = $self->associated_class;
 590     foreach my $handle (keys %handles) {
 591         my $method_to_call = $handles{$handle};
 592         my $class_name = $associated_class->name;
 593         my $name = "${class_name}::${handle}";
 594
 595             (!$associated_class->has_method($handle))
 596                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 597
 598         # NOTE:
 599         # handles is not allowed to delegate
 600         # any of these methods, as they will
 601         # override the ones in your class, which
 602         # is almost certainly not what you want.
 603
 604         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 605         #cluck("Not delegating method '$handle' because it is a core method") and
 606         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 607
 608         my $method = $self->_make_delegation_method($handle, $method_to_call);
 609
 610         $self->associated_class->add_method($method->name, $method);
 611         $self->associate_method($method);
 612     }
 613 }
 614
 615 sub remove_delegation {
 616     my $self = shift;
 617     my %handles = $self->_canonicalize_handles;
 618     my $associated_class = $self->associated_class;
 619     foreach my $handle (keys %handles) {
 620         $self->associated_class->remove_method($handle);
 621     }
 622 }
 623
 624 # private methods to help delegation ...
 625
 626 sub _canonicalize_handles {
 627     my $self    = shift;
 628     my $handles = $self->handles;
 629     if (my $handle_type = ref($handles)) {
 630         if ($handle_type eq 'HASH') {
 631             return %{$handles};
 632         }
 633         elsif ($handle_type eq 'ARRAY') {
 634             return map { $_ => $_ } @{$handles};
 635         }
 636         elsif ($handle_type eq 'Regexp') {
 637             ($self->has_type_constraint)
 638                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 639             return map  { ($_ => $_) }
 640                    grep { /$handles/ } $self->_get_delegate_method_list;
 641         }
 642         elsif ($handle_type eq 'CODE') {
 643             return $handles->($self, $self->_find_delegate_metaclass);
 644         }
 645         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
 646             return map { $_ => $_ } @{ $handles->methods };
 647         }
 648         else {
 649             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 650         }
 651     }
 652     else {
 653         Class::MOP::load_class($handles);
 654         my $role_meta = Class::MOP::class_of($handles);
 655
 656         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 657             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 658
 659         return map { $_ => $_ } (
 660             $role_meta->get_method_list,
 661             map { $_->name } $role_meta->get_required_method_list,
 662         );
 663     }
 664 }
 665
 666 sub _find_delegate_metaclass {
 667     my $self = shift;
 668     if (my $class = $self->_isa_metadata) {
 669         # we might be dealing with a non-Moose class,
 670         # and need to make our own metaclass. if there's
 671         # already a metaclass, it will be returned
 672         return Moose::Meta::Class->initialize($class);
 673     }
 674     elsif (my $role = $self->_does_metadata) {
 675         return Class::MOP::class_of($role);
 676     }
 677     else {
 678         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 679     }
 680 }
 681
 682 sub _get_delegate_method_list {
 683     my $self = shift;
 684     my $meta = $self->_find_delegate_metaclass;
 685     if ($meta->isa('Class::MOP::Class')) {
 686         return map  { $_->name }  # NOTE: !never! delegate &meta
 687                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 688                     $meta->get_all_methods;
 689     }
 690     elsif ($meta->isa('Moose::Meta::Role')) {
 691         return $meta->get_method_list;
 692     }
 693     else {
 694         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 695     }
 696 }
 697
 698 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 699
 700 sub _make_delegation_method {
 701     my ( $self, $handle_name, $method_to_call ) = @_;
 702
 703     my $method_body;
 704
 705     $method_body = $method_to_call
 706         if 'CODE' eq ref($method_to_call);
 707
 708     return $self->delegation_metaclass->new(
 709         name               => $handle_name,
 710         package_name       => $self->associated_class->name,
 711         attribute          => $self,
 712         delegate_to_method => $method_to_call,
 713     );
 714 }
 715
 716 sub _coerce_and_verify {
 717     my $self     = shift;
 718     my $val      = shift;
 719     my $instance = shift;
 720
 721     return $val unless $self->has_type_constraint;
 722
 723     my $type_constraint = $self->type_constraint;
 724     if ($self->should_coerce && $type_constraint->has_coercion) {
 725         $val = $type_constraint->coerce($val);
 726     }
 727
 728     $self->verify_against_type_constraint($val, instance => $instance);
 729
 730     return $val;
 731 }
 732
 733 sub verify_against_type_constraint {
 734     my $self = shift;
 735     my $val  = shift;
 736
 737     return 1 if !$self->has_type_constraint;
 738
 739     my $type_constraint = $self->type_constraint;
 740
 741     $type_constraint->check($val)
 742         || $self->throw_error("Attribute ("
 743                  . $self->name
 744                  . ") does not pass the type constraint because: "
 745                  . $type_constraint->get_message($val), data => $val, @_);
 746 }
 747
 748 package Moose::Meta::Attribute::Custom::Moose;
 749 sub register_implementation { 'Moose::Meta::Attribute' }
 750
 751 1;
 752
 753 __END__
 754
 755 =pod
 756
 757 =head1 NAME
 758
 759 Moose::Meta::Attribute - The Moose attribute metaclass
 760
 761 =head1 DESCRIPTION
 762
 763 This class is a subclass of L<Class::MOP::Attribute> that provides
 764 additional Moose-specific functionality.
 765
 766 To really understand this class, you will need to start with the
 767 L<Class::MOP::Attribute> documentation. This class can be understood
 768 as a set of additional features on top of the basic feature provided
 769 by that parent class.
 770
 771 =head1 INHERITANCE
 772
 773 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 774
 775 =head1 METHODS
 776
 777 Many of the documented below override methods in
 778 L<Class::MOP::Attribute> and add Moose specific features.
 779
 780 =head2 Creation
 781
 782 =over 4
 783
 784 =item B<< Moose::Meta::Attribute->new(%options) >>
 785
 786 This method overrides the L<Class::MOP::Attribute> constructor.
 787
 788 Many of the options below are described in more detail in the
 789 L<Moose::Manual::Attributes> document.
 790
 791 It adds the following options to the constructor:
 792
 793 =over 8
 794
 795 =item * is => 'ro', 'rw', 'bare'
 796
 797 This provides a shorthand for specifying the C<reader>, C<writer>, or
 798 C<accessor> names. If the attribute is read-only ('ro') then it will
 799 have a C<reader> method with the same attribute as the name.
 800
 801 If it is read-write ('rw') then it will have an C<accessor> method
 802 with the same name. If you provide an explicit C<writer> for a
 803 read-write attribute, then you will have a C<reader> with the same
 804 name as the attribute, and a C<writer> with the name you provided.
 805
 806 Use 'bare' when you are deliberately not installing any methods
 807 (accessor, reader, etc.) associated with this attribute; otherwise,
 808 Moose will issue a deprecation warning when this attribute is added to a
 809 metaclass.
 810
 811 =item * isa => $type
 812
 813 This option accepts a type. The type can be a string, which should be
 814 a type name. If the type name is unknown, it is assumed to be a class
 815 name.
 816
 817 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 818
 819 If you I<also> provide a C<does> option, then your C<isa> option must
 820 be a class name, and that class must do the role specified with
 821 C<does>.
 822
 823 =item * does => $role
 824
 825 This is short-hand for saying that the attribute's type must be an
 826 object which does the named role.
 827
 828 =item * coerce => $bool
 829
 830 This option is only valid for objects with a type constraint
 831 (C<isa>). If this is true, then coercions will be applied whenever
 832 this attribute is set.
 833
 834 You can make both this and the C<weak_ref> option true.
 835
 836 =item * trigger => $sub
 837
 838 This option accepts a subroutine reference, which will be called after
 839 the attribute is set.
 840
 841 =item * required => $bool
 842
 843 An attribute which is required must be provided to the constructor. An
 844 attribute which is required can also have a C<default> or C<builder>,
 845 which will satisfy its required-ness.
 846
 847 A required attribute must have a C<default>, C<builder> or a
 848 non-C<undef> C<init_arg>
 849
 850 =item * lazy => $bool
 851
 852 A lazy attribute must have a C<default> or C<builder>. When an
 853 attribute is lazy, the default value will not be calculated until the
 854 attribute is read.
 855
 856 =item * weak_ref => $bool
 857
 858 If this is true, the attribute's value will be stored as a weak
 859 reference.
 860
 861 =item * auto_deref => $bool
 862
 863 If this is true, then the reader will dereference the value when it is
 864 called. The attribute must have a type constraint which defines the
 865 attribute as an array or hash reference.
 866
 867 =item * lazy_build => $bool
 868
 869 Setting this to true makes the attribute lazy and provides a number of
 870 default methods.
 871
 872   has 'size' => (
 873       is         => 'ro',
 874       lazy_build => 1,
 875   );
 876
 877 is equivalent to this:
 878
 879   has 'size' => (
 880       is        => 'ro',
 881       lazy      => 1,
 882       builder   => '_build_size',
 883       clearer   => 'clear_size',
 884       predicate => 'has_size',
 885   );
 886
 887 =item * documentation
 888
 889 An arbitrary string that can be retrieved later by calling C<<
 890 $attr->documentation >>.
 891
 892 =back
 893
 894 =item B<< $attr->clone(%options) >>
 895
 896 This creates a new attribute based on attribute being cloned. You must
 897 supply a C<name> option to provide a new name for the attribute.
 898
 899 The C<%options> can only specify options handled by
 900 L<Class::MOP::Attribute>.
 901
 902 =back
 903
 904 =head2 Value management
 905
 906 =over 4
 907
 908 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 909
 910 This method is used internally to initialize the attribute's slot in
 911 the object C<$instance>.
 912
 913 This overrides the L<Class::MOP::Attribute> method to handle lazy
 914 attributes, weak references, and type constraints.
 915
 916 =item B<get_value>
 917
 918 =item B<set_value>
 919
 920   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 921   if($@) {
 922     print "Oops: $@\n";
 923   }
 924
 925 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 926
 927 Before setting the value, a check is made on the type constraint of
 928 the attribute, if it has one, to see if the value passes it. If the
 929 value fails to pass, the set operation dies with a L<throw_error>.
 930
 931 Any coercion to convert values is done before checking the type constraint.
 932
 933 To check a value against a type constraint before setting it, fetch the
 934 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 935 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 936 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 937 for an example.
 938
 939 =back
 940
 941 =head2 Attribute Accessor generation
 942
 943 =over 4
 944
 945 =item B<< $attr->install_accessors >>
 946
 947 This method overrides the parent to also install delegation methods.
 948
 949 If, after installing all methods, the attribute object has no associated
 950 methods, it throws an error unless C<< is => 'bare' >> was passed to the
 951 attribute constructor.  (Trying to add an attribute that has no associated
 952 methods is almost always an error.)
 953
 954 =item B<< $attr->remove_accessors >>
 955
 956 This method overrides the parent to also remove delegation methods.
 957
 958 =item B<< $attr->install_delegation >>
 959
 960 This method adds its delegation methods to the attribute's associated
 961 class, if it has any to add.
 962
 963 =item B<< $attr->remove_delegation >>
 964
 965 This method remove its delegation methods from the attribute's
 966 associated class.
 967
 968 =item B<< $attr->accessor_metaclass >>
 969
 970 Returns the accessor metaclass name, which defaults to
 971 L<Moose::Meta::Method::Accessor>.
 972
 973 =item B<< $attr->delegation_metaclass >>
 974
 975 Returns the delegation metaclass name, which defaults to
 976 L<Moose::Meta::Method::Delegation>.
 977
 978 =back
 979
 980 =head2 Additional Moose features
 981
 982 These methods are not found in the superclass. They support features
 983 provided by Moose.
 984
 985 =over 4
 986
 987 =item B<< $attr->does($role) >>
 988
 989 This indicates whether the I<attribute itself> does the given
 990 role. The role can be given as a full class name, or as a resolvable
 991 trait name.
 992
 993 Note that this checks the attribute itself, not its type constraint,
 994 so it is checking the attribute's metaclass and any traits applied to
 995 the attribute.
 996
 997 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
 998
 999 This is an alternate constructor that handles the C<metaclass> and
1000 C<traits> options.
1001
1002 Effectively, this method is a factory that finds or creates the
1003 appropriate class for the given C<metaclass> and/or C<traits>.
1004
1005 Once it has the appropriate class, it will call C<< $class->new($name,
1006 %options) >> on that class.
1007
1008 =item B<< $attr->clone_and_inherit_options(%options) >>
1009
1010 This method supports the C<has '+foo'> feature. It does various bits
1011 of processing on the supplied C<%options> before ultimately calling
1012 the C<clone> method.
1013
1014 One of its main tasks is to make sure that the C<%options> provided
1015 only includes the options returned by the
1016 C<legal_options_for_inheritance> method.
1017
1018 =item B<< $attr->legal_options_for_inheritance >>
1019
1020 This returns a whitelist of options that can be overridden in a
1021 subclass's attribute definition.
1022
1023 This exists to allow a custom metaclass to change or add to the list
1024 of options which can be changed.
1025
1026 =item B<< $attr->type_constraint >>
1027
1028 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1029 if it has one.
1030
1031 =item B<< $attr->has_type_constraint >>
1032
1033 Returns true if this attribute has a type constraint.
1034
1035 =item B<< $attr->verify_against_type_constraint($value) >>
1036
1037 Given a value, this method returns true if the value is valid for the
1038 attribute's type constraint. If the value is not valid, it throws an
1039 error.
1040
1041 =item B<< $attr->handles >>
1042
1043 This returns the value of the C<handles> option passed to the
1044 constructor.
1045
1046 =item B<< $attr->has_handles >>
1047
1048 Returns true if this attribute performs delegation.
1049
1050 =item B<< $attr->is_weak_ref >>
1051
1052 Returns true if this attribute stores its value as a weak reference.
1053
1054 =item B<< $attr->is_required >>
1055
1056 Returns true if this attribute is required to have a value.
1057
1058 =item B<< $attr->is_lazy >>
1059
1060 Returns true if this attribute is lazy.
1061
1062 =item B<< $attr->is_lazy_build >>
1063
1064 Returns true if the C<lazy_build> option was true when passed to the
1065 constructor.
1066
1067 =item B<< $attr->should_coerce >>
1068
1069 Returns true if the C<coerce> option passed to the constructor was
1070 true.
1071
1072 =item B<< $attr->should_auto_deref >>
1073
1074 Returns true if the C<auto_deref> option passed to the constructor was
1075 true.
1076
1077 =item B<< $attr->trigger >>
1078
1079 This is the subroutine reference that was in the C<trigger> option
1080 passed to the constructor, if any.
1081
1082 =item B<< $attr->has_trigger >>
1083
1084 Returns true if this attribute has a trigger set.
1085
1086 =item B<< $attr->documentation >>
1087
1088 Returns the value that was in the C<documentation> option passed to
1089 the constructor, if any.
1090
1091 =item B<< $attr->has_documentation >>
1092
1093 Returns true if this attribute has any documentation.
1094
1095 =item B<< $attr->applied_traits >>
1096
1097 This returns an array reference of all the traits which were applied
1098 to this attribute. If none were applied, this returns C<undef>.
1099
1100 =item B<< $attr->has_applied_traits >>
1101
1102 Returns true if this attribute has any traits applied.
1103
1104 =back
1105
1106 =head1 BUGS
1107
1108 All complex software has bugs lurking in it, and this module is no
1109 exception. If you find a bug please either email me, or add the bug
1110 to cpan-RT.
1111
1112 =head1 AUTHOR
1113
1114 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1115
1116 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1117
1118 =head1 COPYRIGHT AND LICENSE
1119
1120 Copyright 2006-2009 by Infinity Interactive, Inc.
1121
1122 L<http://www.iinteractive.com>
1123
1124 This library is free software; you can redistribute it and/or modify
1125 it under the same terms as Perl itself.
1126
1127 =cut