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     my $curried_arguments = [];
 695
 696     ($method_to_call, $curried_arguments) = @$method_to_call
 697         if 'ARRAY' 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         curried_arguments  => $curried_arguments,
 705     );
 706 }
 707
 708 sub _coerce_and_verify {
 709     my $self     = shift;
 710     my $val      = shift;
 711     my $instance = shift;
 712
 713     return $val unless $self->has_type_constraint;
 714
 715     my $type_constraint = $self->type_constraint;
 716     if ($self->should_coerce && $type_constraint->has_coercion) {
 717         $val = $type_constraint->coerce($val);
 718     }
 719
 720     $self->verify_against_type_constraint($val, instance => $instance);
 721
 722     return $val;
 723 }
 724
 725 sub verify_against_type_constraint {
 726     my $self = shift;
 727     my $val  = shift;
 728
 729     return 1 if !$self->has_type_constraint;
 730
 731     my $type_constraint = $self->type_constraint;
 732
 733     $type_constraint->check($val)
 734         || $self->throw_error("Attribute ("
 735                  . $self->name
 736                  . ") does not pass the type constraint because: "
 737                  . $type_constraint->get_message($val), data => $val, @_);
 738 }
 739
 740 package Moose::Meta::Attribute::Custom::Moose;
 741 sub register_implementation { 'Moose::Meta::Attribute' }
 742
 743 1;
 744
 745 __END__
 746
 747 =pod
 748
 749 =head1 NAME
 750
 751 Moose::Meta::Attribute - The Moose attribute metaclass
 752
 753 =head1 DESCRIPTION
 754
 755 This class is a subclass of L<Class::MOP::Attribute> that provides
 756 additional Moose-specific functionality.
 757
 758 To really understand this class, you will need to start with the
 759 L<Class::MOP::Attribute> documentation. This class can be understood
 760 as a set of additional features on top of the basic feature provided
 761 by that parent class.
 762
 763 =head1 INHERITANCE
 764
 765 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 766
 767 =head1 METHODS
 768
 769 Many of the documented below override methods in
 770 L<Class::MOP::Attribute> and add Moose specific features.
 771
 772 =head2 Creation
 773
 774 =over 4
 775
 776 =item B<< Moose::Meta::Attribute->new(%options) >>
 777
 778 This method overrides the L<Class::MOP::Attribute> constructor.
 779
 780 Many of the options below are described in more detail in the
 781 L<Moose::Manual::Attributes> document.
 782
 783 It adds the following options to the constructor:
 784
 785 =over 8
 786
 787 =item * is => 'ro', 'rw', 'bare'
 788
 789 This provides a shorthand for specifying the C<reader>, C<writer>, or
 790 C<accessor> names. If the attribute is read-only ('ro') then it will
 791 have a C<reader> method with the same attribute as the name.
 792
 793 If it is read-write ('rw') then it will have an C<accessor> method
 794 with the same name. If you provide an explicit C<writer> for a
 795 read-write attribute, then you will have a C<reader> with the same
 796 name as the attribute, and a C<writer> with the name you provided.
 797
 798 Use 'bare' when you are deliberately not installing any methods
 799 (accessor, reader, etc.) associated with this attribute; otherwise,
 800 Moose will issue a deprecation warning when this attribute is added to a
 801 metaclass.
 802
 803 =item * isa => $type
 804
 805 This option accepts a type. The type can be a string, which should be
 806 a type name. If the type name is unknown, it is assumed to be a class
 807 name.
 808
 809 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 810
 811 If you I<also> provide a C<does> option, then your C<isa> option must
 812 be a class name, and that class must do the role specified with
 813 C<does>.
 814
 815 =item * does => $role
 816
 817 This is short-hand for saying that the attribute's type must be an
 818 object which does the named role.
 819
 820 =item * coerce => $bool
 821
 822 This option is only valid for objects with a type constraint
 823 (C<isa>). If this is true, then coercions will be applied whenever
 824 this attribute is set.
 825
 826 You can make both this and the C<weak_ref> option true.
 827
 828 =item * trigger => $sub
 829
 830 This option accepts a subroutine reference, which will be called after
 831 the attribute is set.
 832
 833 =item * required => $bool
 834
 835 An attribute which is required must be provided to the constructor. An
 836 attribute which is required can also have a C<default> or C<builder>,
 837 which will satisfy its required-ness.
 838
 839 A required attribute must have a C<default>, C<builder> or a
 840 non-C<undef> C<init_arg>
 841
 842 =item * lazy => $bool
 843
 844 A lazy attribute must have a C<default> or C<builder>. When an
 845 attribute is lazy, the default value will not be calculated until the
 846 attribute is read.
 847
 848 =item * weak_ref => $bool
 849
 850 If this is true, the attribute's value will be stored as a weak
 851 reference.
 852
 853 =item * auto_deref => $bool
 854
 855 If this is true, then the reader will dereference the value when it is
 856 called. The attribute must have a type constraint which defines the
 857 attribute as an array or hash reference.
 858
 859 =item * lazy_build => $bool
 860
 861 Setting this to true makes the attribute lazy and provides a number of
 862 default methods.
 863
 864   has 'size' => (
 865       is         => 'ro',
 866       lazy_build => 1,
 867   );
 868
 869 is equivalent to this:
 870
 871   has 'size' => (
 872       is        => 'ro',
 873       lazy      => 1,
 874       builder   => '_build_size',
 875       clearer   => 'clear_size',
 876       predicate => 'has_size',
 877   );
 878
 879 =item * documentation
 880
 881 An arbitrary string that can be retrieved later by calling C<<
 882 $attr->documentation >>.
 883
 884 =back
 885
 886 =item B<< $attr->clone(%options) >>
 887
 888 This creates a new attribute based on attribute being cloned. You must
 889 supply a C<name> option to provide a new name for the attribute.
 890
 891 The C<%options> can only specify options handled by
 892 L<Class::MOP::Attribute>.
 893
 894 =back
 895
 896 =head2 Value management
 897
 898 =over 4
 899
 900 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 901
 902 This method is used internally to initialize the attribute's slot in
 903 the object C<$instance>.
 904
 905 This overrides the L<Class::MOP::Attribute> method to handle lazy
 906 attributes, weak references, and type constraints.
 907
 908 =item B<get_value>
 909
 910 =item B<set_value>
 911
 912   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 913   if($@) {
 914     print "Oops: $@\n";
 915   }
 916
 917 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 918
 919 Before setting the value, a check is made on the type constraint of
 920 the attribute, if it has one, to see if the value passes it. If the
 921 value fails to pass, the set operation dies with a L<throw_error>.
 922
 923 Any coercion to convert values is done before checking the type constraint.
 924
 925 To check a value against a type constraint before setting it, fetch the
 926 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 927 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 928 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 929 for an example.
 930
 931 =back
 932
 933 =head2 Attribute Accessor generation
 934
 935 =over 4
 936
 937 =item B<< $attr->install_accessors >>
 938
 939 This method overrides the parent to also install delegation methods.
 940
 941 If, after installing all methods, the attribute object has no associated
 942 methods, it throws an error unless C<< is => 'bare' >> was passed to the
 943 attribute constructor.  (Trying to add an attribute that has no associated
 944 methods is almost always an error.)
 945
 946 =item B<< $attr->remove_accessors >>
 947
 948 This method overrides the parent to also remove delegation methods.
 949
 950 =item B<< $attr->install_delegation >>
 951
 952 This method adds its delegation methods to the attribute's associated
 953 class, if it has any to add.
 954
 955 =item B<< $attr->remove_delegation >>
 956
 957 This method remove its delegation methods from the attribute's
 958 associated class.
 959
 960 =item B<< $attr->accessor_metaclass >>
 961
 962 Returns the accessor metaclass name, which defaults to
 963 L<Moose::Meta::Method::Accessor>.
 964
 965 =item B<< $attr->delegation_metaclass >>
 966
 967 Returns the delegation metaclass name, which defaults to
 968 L<Moose::Meta::Method::Delegation>.
 969
 970 =back
 971
 972 =head2 Additional Moose features
 973
 974 These methods are not found in the superclass. They support features
 975 provided by Moose.
 976
 977 =over 4
 978
 979 =item B<< $attr->does($role) >>
 980
 981 This indicates whether the I<attribute itself> does the given
 982 role. The role can be given as a full class name, or as a resolvable
 983 trait name.
 984
 985 Note that this checks the attribute itself, not its type constraint,
 986 so it is checking the attribute's metaclass and any traits applied to
 987 the attribute.
 988
 989 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
 990
 991 This is an alternate constructor that handles the C<metaclass> and
 992 C<traits> options.
 993
 994 Effectively, this method is a factory that finds or creates the
 995 appropriate class for the given C<metaclass> and/or C<traits>.
 996
 997 Once it has the appropriate class, it will call C<< $class->new($name,
 998 %options) >> on that class.
 999
1000 =item B<< $attr->clone_and_inherit_options(%options) >>
1001
1002 This method supports the C<has '+foo'> feature. It does various bits
1003 of processing on the supplied C<%options> before ultimately calling
1004 the C<clone> method.
1005
1006 One of its main tasks is to make sure that the C<%options> provided
1007 only includes the options returned by the
1008 C<legal_options_for_inheritance> method.
1009
1010 =item B<< $attr->legal_options_for_inheritance >>
1011
1012 This returns a whitelist of options that can be overridden in a
1013 subclass's attribute definition.
1014
1015 This exists to allow a custom metaclass to change or add to the list
1016 of options which can be changed.
1017
1018 =item B<< $attr->type_constraint >>
1019
1020 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1021 if it has one.
1022
1023 =item B<< $attr->has_type_constraint >>
1024
1025 Returns true if this attribute has a type constraint.
1026
1027 =item B<< $attr->verify_against_type_constraint($value) >>
1028
1029 Given a value, this method returns true if the value is valid for the
1030 attribute's type constraint. If the value is not valid, it throws an
1031 error.
1032
1033 =item B<< $attr->handles >>
1034
1035 This returns the value of the C<handles> option passed to the
1036 constructor.
1037
1038 =item B<< $attr->has_handles >>
1039
1040 Returns true if this attribute performs delegation.
1041
1042 =item B<< $attr->is_weak_ref >>
1043
1044 Returns true if this attribute stores its value as a weak reference.
1045
1046 =item B<< $attr->is_required >>
1047
1048 Returns true if this attribute is required to have a value.
1049
1050 =item B<< $attr->is_lazy >>
1051
1052 Returns true if this attribute is lazy.
1053
1054 =item B<< $attr->is_lazy_build >>
1055
1056 Returns true if the C<lazy_build> option was true when passed to the
1057 constructor.
1058
1059 =item B<< $attr->should_coerce >>
1060
1061 Returns true if the C<coerce> option passed to the constructor was
1062 true.
1063
1064 =item B<< $attr->should_auto_deref >>
1065
1066 Returns true if the C<auto_deref> option passed to the constructor was
1067 true.
1068
1069 =item B<< $attr->trigger >>
1070
1071 This is the subroutine reference that was in the C<trigger> option
1072 passed to the constructor, if any.
1073
1074 =item B<< $attr->has_trigger >>
1075
1076 Returns true if this attribute has a trigger set.
1077
1078 =item B<< $attr->documentation >>
1079
1080 Returns the value that was in the C<documentation> option passed to
1081 the constructor, if any.
1082
1083 =item B<< $attr->has_documentation >>
1084
1085 Returns true if this attribute has any documentation.
1086
1087 =item B<< $attr->applied_traits >>
1088
1089 This returns an array reference of all the traits which were applied
1090 to this attribute. If none were applied, this returns C<undef>.
1091
1092 =item B<< $attr->has_applied_traits >>
1093
1094 Returns true if this attribute has any traits applied.
1095
1096 =back
1097
1098 =head1 BUGS
1099
1100 All complex software has bugs lurking in it, and this module is no
1101 exception. If you find a bug please either email me, or add the bug
1102 to cpan-RT.
1103
1104 =head1 AUTHOR
1105
1106 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1107
1108 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1109
1110 =head1 COPYRIGHT AND LICENSE
1111
1112 Copyright 2006-2009 by Infinity Interactive, Inc.
1113
1114 L<http://www.iinteractive.com>
1115
1116 This library is free software; you can redistribute it and/or modify
1117 it under the same terms as Perl itself.
1118
1119 =cut