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 remove_accessors {
 557     my $self = shift;
 558     $self->SUPER::remove_accessors(@_);
 559     $self->remove_delegation if $self->has_handles;
 560     return;
 561 }
 562
 563 sub install_delegation {
 564     my $self = shift;
 565
 566     # NOTE:
 567     # Here we canonicalize the 'handles' option
 568     # this will sort out any details and always
 569     # return an hash of methods which we want
 570     # to delagate to, see that method for details
 571     my %handles = $self->_canonicalize_handles;
 572
 573
 574     # install the delegation ...
 575     my $associated_class = $self->associated_class;
 576     foreach my $handle (keys %handles) {
 577         my $method_to_call = $handles{$handle};
 578         my $class_name = $associated_class->name;
 579         my $name = "${class_name}::${handle}";
 580
 581             (!$associated_class->has_method($handle))
 582                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 583
 584         # NOTE:
 585         # handles is not allowed to delegate
 586         # any of these methods, as they will
 587         # override the ones in your class, which
 588         # is almost certainly not what you want.
 589
 590         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 591         #cluck("Not delegating method '$handle' because it is a core method") and
 592         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 593
 594         my $method = $self->_make_delegation_method($handle, $method_to_call);
 595
 596         $self->associated_class->add_method($method->name, $method);
 597         $self->associate_method($method);
 598     }
 599 }
 600
 601 sub remove_delegation {
 602     my $self = shift;
 603     my %handles = $self->_canonicalize_handles;
 604     my $associated_class = $self->associated_class;
 605     foreach my $handle (keys %handles) {
 606         $self->associated_class->remove_method($handle);
 607     }
 608 }
 609
 610 # private methods to help delegation ...
 611
 612 sub _canonicalize_handles {
 613     my $self    = shift;
 614     my $handles = $self->handles;
 615     if (my $handle_type = ref($handles)) {
 616         if ($handle_type eq 'HASH') {
 617             return %{$handles};
 618         }
 619         elsif ($handle_type eq 'ARRAY') {
 620             return map { $_ => $_ } @{$handles};
 621         }
 622         elsif ($handle_type eq 'Regexp') {
 623             ($self->has_type_constraint)
 624                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 625             return map  { ($_ => $_) }
 626                    grep { /$handles/ } $self->_get_delegate_method_list;
 627         }
 628         elsif ($handle_type eq 'CODE') {
 629             return $handles->($self, $self->_find_delegate_metaclass);
 630         }
 631         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
 632             return map { $_ => $_ } @{ $handles->methods };
 633         }
 634         else {
 635             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 636         }
 637     }
 638     else {
 639         Class::MOP::load_class($handles);
 640         my $role_meta = Class::MOP::class_of($handles);
 641
 642         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 643             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 644
 645         return map { $_ => $_ } (
 646             $role_meta->get_method_list,
 647             map { $_->name } $role_meta->get_required_method_list,
 648         );
 649     }
 650 }
 651
 652 sub _find_delegate_metaclass {
 653     my $self = shift;
 654     if (my $class = $self->_isa_metadata) {
 655         # we might be dealing with a non-Moose class,
 656         # and need to make our own metaclass. if there's
 657         # already a metaclass, it will be returned
 658         return Moose::Meta::Class->initialize($class);
 659     }
 660     elsif (my $role = $self->_does_metadata) {
 661         return Class::MOP::class_of($role);
 662     }
 663     else {
 664         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 665     }
 666 }
 667
 668 sub _get_delegate_method_list {
 669     my $self = shift;
 670     my $meta = $self->_find_delegate_metaclass;
 671     if ($meta->isa('Class::MOP::Class')) {
 672         return map  { $_->name }  # NOTE: !never! delegate &meta
 673                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 674                     $meta->get_all_methods;
 675     }
 676     elsif ($meta->isa('Moose::Meta::Role')) {
 677         return $meta->get_method_list;
 678     }
 679     else {
 680         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 681     }
 682 }
 683
 684 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 685
 686 sub _make_delegation_method {
 687     my ( $self, $handle_name, $method_to_call ) = @_;
 688
 689     my $method_body;
 690
 691     $method_body = $method_to_call
 692         if 'CODE' eq ref($method_to_call);
 693
 694     return $self->delegation_metaclass->new(
 695         name               => $handle_name,
 696         package_name       => $self->associated_class->name,
 697         attribute          => $self,
 698         delegate_to_method => $method_to_call,
 699     );
 700 }
 701
 702 sub _coerce_and_verify {
 703     my $self     = shift;
 704     my $val      = shift;
 705     my $instance = shift;
 706
 707     return $val unless $self->has_type_constraint;
 708
 709     my $type_constraint = $self->type_constraint;
 710     if ($self->should_coerce && $type_constraint->has_coercion) {
 711         $val = $type_constraint->coerce($val);
 712     }
 713
 714     $self->verify_against_type_constraint($val, instance => $instance);
 715
 716     return $val;
 717 }
 718
 719 sub verify_against_type_constraint {
 720     my $self = shift;
 721     my $val  = shift;
 722
 723     return 1 if !$self->has_type_constraint;
 724
 725     my $type_constraint = $self->type_constraint;
 726
 727     $type_constraint->check($val)
 728         || $self->throw_error("Attribute ("
 729                  . $self->name
 730                  . ") does not pass the type constraint because: "
 731                  . $type_constraint->get_message($val), data => $val, @_);
 732 }
 733
 734 package Moose::Meta::Attribute::Custom::Moose;
 735 sub register_implementation { 'Moose::Meta::Attribute' }
 736
 737 1;
 738
 739 __END__
 740
 741 =pod
 742
 743 =head1 NAME
 744
 745 Moose::Meta::Attribute - The Moose attribute metaclass
 746
 747 =head1 DESCRIPTION
 748
 749 This class is a subclass of L<Class::MOP::Attribute> that provides
 750 additional Moose-specific functionality.
 751
 752 To really understand this class, you will need to start with the
 753 L<Class::MOP::Attribute> documentation. This class can be understood
 754 as a set of additional features on top of the basic feature provided
 755 by that parent class.
 756
 757 =head1 INHERITANCE
 758
 759 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 760
 761 =head1 METHODS
 762
 763 Many of the documented below override methods in
 764 L<Class::MOP::Attribute> and add Moose specific features.
 765
 766 =head2 Creation
 767
 768 =over 4
 769
 770 =item B<< Moose::Meta::Attribute->new(%options) >>
 771
 772 This method overrides the L<Class::MOP::Attribute> constructor.
 773
 774 Many of the options below are described in more detail in the
 775 L<Moose::Manual::Attributes> document.
 776
 777 It adds the following options to the constructor:
 778
 779 =over 8
 780
 781 =item * is => 'ro', 'rw', 'bare'
 782
 783 This provides a shorthand for specifying the C<reader>, C<writer>, or
 784 C<accessor> names. If the attribute is read-only ('ro') then it will
 785 have a C<reader> method with the same attribute as the name.
 786
 787 If it is read-write ('rw') then it will have an C<accessor> method
 788 with the same name. If you provide an explicit C<writer> for a
 789 read-write attribute, then you will have a C<reader> with the same
 790 name as the attribute, and a C<writer> with the name you provided.
 791
 792 Use 'bare' when you are deliberately not installing any methods
 793 (accessor, reader, etc.) associated with this attribute; otherwise,
 794 Moose will issue a deprecation warning when this attribute is added to a
 795 metaclass.
 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 If, after installing all methods, the attribute object has no associated
 936 methods, it throws an error unless C<< is => 'bare' >> was passed to the
 937 attribute constructor.  (Trying to add an attribute that has no associated
 938 methods is almost always an error.)
 939
 940 =item B<< $attr->remove_accessors >>
 941
 942 This method overrides the parent to also remove delegation methods.
 943
 944 =item B<< $attr->install_delegation >>
 945
 946 This method adds its delegation methods to the attribute's associated
 947 class, if it has any to add.
 948
 949 =item B<< $attr->remove_delegation >>
 950
 951 This method remove its delegation methods from the attribute's
 952 associated class.
 953
 954 =item B<< $attr->accessor_metaclass >>
 955
 956 Returns the accessor metaclass name, which defaults to
 957 L<Moose::Meta::Method::Accessor>.
 958
 959 =item B<< $attr->delegation_metaclass >>
 960
 961 Returns the delegation metaclass name, which defaults to
 962 L<Moose::Meta::Method::Delegation>.
 963
 964 =back
 965
 966 =head2 Additional Moose features
 967
 968 These methods are not found in the superclass. They support features
 969 provided by Moose.
 970
 971 =over 4
 972
 973 =item B<< $attr->does($role) >>
 974
 975 This indicates whether the I<attribute itself> does the given
 976 role. The role can be given as a full class name, or as a resolvable
 977 trait name.
 978
 979 Note that this checks the attribute itself, not its type constraint,
 980 so it is checking the attribute's metaclass and any traits applied to
 981 the attribute.
 982
 983 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
 984
 985 This is an alternate constructor that handles the C<metaclass> and
 986 C<traits> options.
 987
 988 Effectively, this method is a factory that finds or creates the
 989 appropriate class for the given C<metaclass> and/or C<traits>.
 990
 991 Once it has the appropriate class, it will call C<< $class->new($name,
 992 %options) >> on that class.
 993
 994 =item B<< $attr->clone_and_inherit_options(%options) >>
 995
 996 This method supports the C<has '+foo'> feature. It does various bits
 997 of processing on the supplied C<%options> before ultimately calling
 998 the C<clone> method.
 999
1000 One of its main tasks is to make sure that the C<%options> provided
1001 only includes the options returned by the
1002 C<legal_options_for_inheritance> method.
1003
1004 =item B<< $attr->legal_options_for_inheritance >>
1005
1006 This returns a whitelist of options that can be overridden in a
1007 subclass's attribute definition.
1008
1009 This exists to allow a custom metaclass to change or add to the list
1010 of options which can be changed.
1011
1012 =item B<< $attr->type_constraint >>
1013
1014 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1015 if it has one.
1016
1017 =item B<< $attr->has_type_constraint >>
1018
1019 Returns true if this attribute has a type constraint.
1020
1021 =item B<< $attr->verify_against_type_constraint($value) >>
1022
1023 Given a value, this method returns true if the value is valid for the
1024 attribute's type constraint. If the value is not valid, it throws an
1025 error.
1026
1027 =item B<< $attr->handles >>
1028
1029 This returns the value of the C<handles> option passed to the
1030 constructor.
1031
1032 =item B<< $attr->has_handles >>
1033
1034 Returns true if this attribute performs delegation.
1035
1036 =item B<< $attr->is_weak_ref >>
1037
1038 Returns true if this attribute stores its value as a weak reference.
1039
1040 =item B<< $attr->is_required >>
1041
1042 Returns true if this attribute is required to have a value.
1043
1044 =item B<< $attr->is_lazy >>
1045
1046 Returns true if this attribute is lazy.
1047
1048 =item B<< $attr->is_lazy_build >>
1049
1050 Returns true if the C<lazy_build> option was true when passed to the
1051 constructor.
1052
1053 =item B<< $attr->should_coerce >>
1054
1055 Returns true if the C<coerce> option passed to the constructor was
1056 true.
1057
1058 =item B<< $attr->should_auto_deref >>
1059
1060 Returns true if the C<auto_deref> option passed to the constructor was
1061 true.
1062
1063 =item B<< $attr->trigger >>
1064
1065 This is the subroutine reference that was in the C<trigger> option
1066 passed to the constructor, if any.
1067
1068 =item B<< $attr->has_trigger >>
1069
1070 Returns true if this attribute has a trigger set.
1071
1072 =item B<< $attr->documentation >>
1073
1074 Returns the value that was in the C<documentation> option passed to
1075 the constructor, if any.
1076
1077 =item B<< $attr->has_documentation >>
1078
1079 Returns true if this attribute has any documentation.
1080
1081 =item B<< $attr->applied_traits >>
1082
1083 This returns an array reference of all the traits which were applied
1084 to this attribute. If none were applied, this returns C<undef>.
1085
1086 =item B<< $attr->has_applied_traits >>
1087
1088 Returns true if this attribute has any traits applied.
1089
1090 =back
1091
1092 =head1 BUGS
1093
1094 All complex software has bugs lurking in it, and this module is no
1095 exception. If you find a bug please either email me, or add the bug
1096 to cpan-RT.
1097
1098 =head1 AUTHOR
1099
1100 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1101
1102 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1103
1104 =head1 COPYRIGHT AND LICENSE
1105
1106 Copyright 2006-2009 by Infinity Interactive, Inc.
1107
1108 L<http://www.iinteractive.com>
1109
1110 This library is free software; you can redistribute it and/or modify
1111 it under the same terms as Perl itself.
1112
1113 =cut