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