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