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         else {
 294             $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
 295         }
 296     }
 297
 298     if (exists $options->{isa}) {
 299         if (exists $options->{does}) {
 300             if (eval { $options->{isa}->can('does') }) {
 301                 ($options->{isa}->does($options->{does}))
 302                     || $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);
 303             }
 304             else {
 305                 $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
 306             }
 307         }
 308
 309         # allow for anon-subtypes here ...
 310         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 311             $options->{type_constraint} = $options->{isa};
 312         }
 313         else {
 314             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
 315         }
 316     }
 317     elsif (exists $options->{does}) {
 318         # allow for anon-subtypes here ...
 319         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 320                 $options->{type_constraint} = $options->{does};
 321         }
 322         else {
 323             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
 324         }
 325     }
 326
 327     if (exists $options->{coerce} && $options->{coerce}) {
 328         (exists $options->{type_constraint})
 329             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options);
 330         $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options)
 331             if $options->{weak_ref};
 332     }
 333
 334     if (exists $options->{trigger}) {
 335         ('CODE' eq ref $options->{trigger})
 336             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
 337     }
 338
 339     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 340         (exists $options->{type_constraint})
 341             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options);
 342         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 343          $options->{type_constraint}->is_a_type_of('HashRef'))
 344             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options);
 345     }
 346
 347     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
 348         $class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options)
 349             if exists $options->{default};
 350         $options->{lazy}      = 1;
 351         $options->{builder} ||= "_build_${name}";
 352         if ($name =~ /^_/) {
 353             $options->{clearer}   ||= "_clear${name}";
 354             $options->{predicate} ||= "_has${name}";
 355         }
 356         else {
 357             $options->{clearer}   ||= "clear_${name}";
 358             $options->{predicate} ||= "has_${name}";
 359         }
 360     }
 361
 362     if (exists $options->{lazy} && $options->{lazy}) {
 363         (exists $options->{default} || defined $options->{builder} )
 364             || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
 365     }
 366
 367     if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
 368         $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
 369     }
 370
 371 }
 372
 373 sub initialize_instance_slot {
 374     my ($self, $meta_instance, $instance, $params) = @_;
 375     my $init_arg = $self->init_arg();
 376     # try to fetch the init arg from the %params ...
 377
 378     my $val;
 379     my $value_is_set;
 380     if ( defined($init_arg) and exists $params->{$init_arg}) {
 381         $val = $params->{$init_arg};
 382         $value_is_set = 1;
 383     }
 384     else {
 385         # skip it if it's lazy
 386         return if $self->is_lazy;
 387         # and die if it's required and doesn't have a default value
 388         $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
 389             if $self->is_required && !$self->has_default && !$self->has_builder;
 390
 391         # if nothing was in the %params, we can use the
 392         # attribute's default value (if it has one)
 393         if ($self->has_default) {
 394             $val = $self->default($instance);
 395             $value_is_set = 1;
 396         }
 397         elsif ($self->has_builder) {
 398             $val = $self->_call_builder($instance);
 399             $value_is_set = 1;
 400         }
 401     }
 402
 403     return unless $value_is_set;
 404
 405     $val = $self->_coerce_and_verify( $val, $instance );
 406
 407     $self->set_initial_value($instance, $val);
 408     $meta_instance->weaken_slot_value($instance, $self->name)
 409         if ref $val && $self->is_weak_ref;
 410 }
 411
 412 sub _call_builder {
 413     my ( $self, $instance ) = @_;
 414
 415     my $builder = $self->builder();
 416
 417     return $instance->$builder()
 418         if $instance->can( $self->builder );
 419
 420     $self->throw_error(  blessed($instance)
 421             . " does not support builder method '"
 422             . $self->builder
 423             . "' for attribute '"
 424             . $self->name
 425             . "'",
 426             object => $instance,
 427      );
 428 }
 429
 430 ## Slot management
 431
 432 # FIXME:
 433 # this duplicates too much code from
 434 # Class::MOP::Attribute, we need to
 435 # refactor these bits eventually.
 436 # - SL
 437 sub _set_initial_slot_value {
 438     my ($self, $meta_instance, $instance, $value) = @_;
 439
 440     my $slot_name = $self->name;
 441
 442     return $meta_instance->set_slot_value($instance, $slot_name, $value)
 443         unless $self->has_initializer;
 444
 445     my ($type_constraint, $can_coerce);
 446     if ($self->has_type_constraint) {
 447         $type_constraint = $self->type_constraint;
 448         $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
 449     }
 450
 451     my $callback = sub {
 452         my $val = $self->_coerce_and_verify( shift, $instance );;
 453
 454         $meta_instance->set_slot_value($instance, $slot_name, $val);
 455     };
 456
 457     my $initializer = $self->initializer;
 458
 459     # most things will just want to set a value, so make it first arg
 460     $instance->$initializer($value, $callback, $self);
 461 }
 462
 463 sub set_value {
 464     my ($self, $instance, @args) = @_;
 465     my $value = $args[0];
 466
 467     my $attr_name = $self->name;
 468
 469     if ($self->is_required and not @args) {
 470         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
 471     }
 472
 473     $value = $self->_coerce_and_verify( $value, $instance );
 474
 475     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 476                                          ->get_meta_instance;
 477
 478     $meta_instance->set_slot_value($instance, $attr_name, $value);
 479
 480     if (ref $value && $self->is_weak_ref) {
 481         $meta_instance->weaken_slot_value($instance, $attr_name);
 482     }
 483
 484     if ($self->has_trigger) {
 485         $self->trigger->($instance, $value);
 486     }
 487 }
 488
 489 sub get_value {
 490     my ($self, $instance) = @_;
 491
 492     if ($self->is_lazy) {
 493         unless ($self->has_value($instance)) {
 494             my $value;
 495             if ($self->has_default) {
 496                 $value = $self->default($instance);
 497             } elsif ( $self->has_builder ) {
 498                 $value = $self->_call_builder($instance);
 499             }
 500
 501             $value = $self->_coerce_and_verify( $value, $instance );
 502
 503             $self->set_initial_value($instance, $value);
 504         }
 505     }
 506
 507     if ($self->should_auto_deref) {
 508
 509         my $type_constraint = $self->type_constraint;
 510
 511         if ($type_constraint->is_a_type_of('ArrayRef')) {
 512             my $rv = $self->SUPER::get_value($instance);
 513             return unless defined $rv;
 514             return wantarray ? @{ $rv } : $rv;
 515         }
 516         elsif ($type_constraint->is_a_type_of('HashRef')) {
 517             my $rv = $self->SUPER::get_value($instance);
 518             return unless defined $rv;
 519             return wantarray ? %{ $rv } : $rv;
 520         }
 521         else {
 522             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
 523         }
 524
 525     }
 526     else {
 527
 528         return $self->SUPER::get_value($instance);
 529     }
 530 }
 531
 532 ## installing accessors
 533
 534 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 535
 536 sub install_accessors {
 537     my $self = shift;
 538     $self->SUPER::install_accessors(@_);
 539     $self->install_delegation if $self->has_handles;
 540     unless (
 541         # XXX handles should be in associated_methods
 542         $self->has_handles
 543         || @{ $self->associated_methods }
 544         || ($self->_is_metadata || '') eq 'bare'
 545     ) {
 546         Carp::cluck(
 547             'Attribute (' . $self->name . ') has no associated methods'
 548             . ' (did you mean to provide an "is" argument?)'
 549             . "\n"
 550         )
 551     }
 552     return;
 553 }
 554
 555 sub remove_accessors {
 556     my $self = shift;
 557     $self->SUPER::remove_accessors(@_);
 558     $self->remove_delegation if $self->has_handles;
 559     return;
 560 }
 561
 562 sub install_delegation {
 563     my $self = shift;
 564
 565     # NOTE:
 566     # Here we canonicalize the 'handles' option
 567     # this will sort out any details and always
 568     # return an hash of methods which we want
 569     # to delagate to, see that method for details
 570     my %handles = $self->_canonicalize_handles;
 571
 572
 573     # install the delegation ...
 574     my $associated_class = $self->associated_class;
 575     foreach my $handle (keys %handles) {
 576         my $method_to_call = $handles{$handle};
 577         my $class_name = $associated_class->name;
 578         my $name = "${class_name}::${handle}";
 579
 580             (!$associated_class->has_method($handle))
 581                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 582
 583         # NOTE:
 584         # handles is not allowed to delegate
 585         # any of these methods, as they will
 586         # override the ones in your class, which
 587         # is almost certainly not what you want.
 588
 589         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 590         #cluck("Not delegating method '$handle' because it is a core method") and
 591         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 592
 593         my $method = $self->_make_delegation_method($handle, $method_to_call);
 594
 595         $self->associated_class->add_method($method->name, $method);
 596     }
 597 }
 598
 599 sub remove_delegation {
 600     my $self = shift;
 601     my %handles = $self->_canonicalize_handles;
 602     my $associated_class = $self->associated_class;
 603     foreach my $handle (keys %handles) {
 604         $self->associated_class->remove_method($handle);
 605     }
 606 }
 607
 608 # private methods to help delegation ...
 609
 610 sub _canonicalize_handles {
 611     my $self    = shift;
 612     my $handles = $self->handles;
 613     if (my $handle_type = ref($handles)) {
 614         if ($handle_type eq 'HASH') {
 615             return %{$handles};
 616         }
 617         elsif ($handle_type eq 'ARRAY') {
 618             return map { $_ => $_ } @{$handles};
 619         }
 620         elsif ($handle_type eq 'Regexp') {
 621             ($self->has_type_constraint)
 622                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 623             return map  { ($_ => $_) }
 624                    grep { /$handles/ } $self->_get_delegate_method_list;
 625         }
 626         elsif ($handle_type eq 'CODE') {
 627             return $handles->($self, $self->_find_delegate_metaclass);
 628         }
 629         else {
 630             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 631         }
 632     }
 633     else {
 634         Class::MOP::load_class($handles);
 635         my $role_meta = Class::MOP::class_of($handles);
 636
 637         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 638             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 639
 640         return map { $_ => $_ } (
 641             $role_meta->get_method_list,
 642             map { $_->name } $role_meta->get_required_method_list,
 643         );
 644     }
 645 }
 646
 647 sub _find_delegate_metaclass {
 648     my $self = shift;
 649     if (my $class = $self->_isa_metadata) {
 650         # we might be dealing with a non-Moose class,
 651         # and need to make our own metaclass. if there's
 652         # already a metaclass, it will be returned
 653         return Moose::Meta::Class->initialize($class);
 654     }
 655     elsif (my $role = $self->_does_metadata) {
 656         return Class::MOP::class_of($role);
 657     }
 658     else {
 659         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 660     }
 661 }
 662
 663 sub _get_delegate_method_list {
 664     my $self = shift;
 665     my $meta = $self->_find_delegate_metaclass;
 666     if ($meta->isa('Class::MOP::Class')) {
 667         return map  { $_->name }  # NOTE: !never! delegate &meta
 668                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 669                     $meta->get_all_methods;
 670     }
 671     elsif ($meta->isa('Moose::Meta::Role')) {
 672         return $meta->get_method_list;
 673     }
 674     else {
 675         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 676     }
 677 }
 678
 679 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 680
 681 sub _make_delegation_method {
 682     my ( $self, $handle_name, $method_to_call ) = @_;
 683
 684     my $method_body;
 685
 686     $method_body = $method_to_call
 687         if 'CODE' eq ref($method_to_call);
 688
 689     return $self->delegation_metaclass->new(
 690         name               => $handle_name,
 691         package_name       => $self->associated_class->name,
 692         attribute          => $self,
 693         delegate_to_method => $method_to_call,
 694     );
 695 }
 696
 697 sub _coerce_and_verify {
 698     my $self     = shift;
 699     my $val      = shift;
 700     my $instance = shift;
 701
 702     return $val unless $self->has_type_constraint;
 703
 704     my $type_constraint = $self->type_constraint;
 705     if ($self->should_coerce && $type_constraint->has_coercion) {
 706         $val = $type_constraint->coerce($val);
 707     }
 708
 709     $self->verify_against_type_constraint($val, instance => $instance);
 710
 711     return $val;
 712 }
 713
 714 sub verify_against_type_constraint {
 715     my $self = shift;
 716     my $val  = shift;
 717
 718     return 1 if !$self->has_type_constraint;
 719
 720     my $type_constraint = $self->type_constraint;
 721
 722     $type_constraint->check($val)
 723         || $self->throw_error("Attribute ("
 724                  . $self->name
 725                  . ") does not pass the type constraint because: "
 726                  . $type_constraint->get_message($val), data => $val, @_);
 727 }
 728
 729 package Moose::Meta::Attribute::Custom::Moose;
 730 sub register_implementation { 'Moose::Meta::Attribute' }
 731
 732 1;
 733
 734 __END__
 735
 736 =pod
 737
 738 =head1 NAME
 739
 740 Moose::Meta::Attribute - The Moose attribute metaclass
 741
 742 =head1 DESCRIPTION
 743
 744 This class is a subclass of L<Class::MOP::Attribute> that provides
 745 additional Moose-specific functionality.
 746
 747 To really understand this class, you will need to start with the
 748 L<Class::MOP::Attribute> documentation. This class can be understood
 749 as a set of additional features on top of the basic feature provided
 750 by that parent class.
 751
 752 =head1 INHERITANCE
 753
 754 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 755
 756 =head1 METHODS
 757
 758 Many of the documented below override methods in
 759 L<Class::MOP::Attribute> and add Moose specific features.
 760
 761 =head2 Creation
 762
 763 =over 4
 764
 765 =item B<< Moose::Meta::Attribute->new(%options) >>
 766
 767 This method overrides the L<Class::MOP::Attribute> constructor.
 768
 769 Many of the options below are described in more detail in the
 770 L<Moose::Manual::Attributes> document.
 771
 772 It adds the following options to the constructor:
 773
 774 =over 8
 775
 776 =item * is => 'ro' or 'rw'
 777
 778 This provides a shorthand for specifying the C<reader>, C<writer>, or
 779 C<accessor> names. If the attribute is read-only ('ro') then it will
 780 have a C<reader> method with the same attribute as the name.
 781
 782 If it is read-write ('rw') then it will have an C<accessor> method
 783 with the same name. If you provide an explicit C<writer> for a
 784 read-write attribute, then you will have a C<reader> with the same
 785 name as the attribute, and a C<writer> with the name you provided.
 786
 787 =item * isa => $type
 788
 789 This option accepts a type. The type can be a string, which should be
 790 a type name. If the type name is unknown, it is assumed to be a class
 791 name.
 792
 793 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 794
 795 If you I<also> provide a C<does> option, then your C<isa> option must
 796 be a class name, and that class must do the role specified with
 797 C<does>.
 798
 799 =item * does => $role
 800
 801 This is short-hand for saying that the attribute's type must be an
 802 object which does the named role.
 803
 804 =item * coerce => $bool
 805
 806 This option is only valid for objects with a type constraint
 807 (C<isa>). If this is true, then coercions will be applied whenever
 808 this attribute is set.
 809
 810 You can make both this and the C<weak_ref> option true.
 811
 812 =item * trigger => $sub
 813
 814 This option accepts a subroutine reference, which will be called after
 815 the attribute is set.
 816
 817 =item * required => $bool
 818
 819 An attribute which is required must be provided to the constructor. An
 820 attribute which is required can also have a C<default> or C<builder>,
 821 which will satisfy its required-ness.
 822
 823 A required attribute must have a C<default>, C<builder> or a
 824 non-C<undef> C<init_arg>
 825
 826 =item * lazy => $bool
 827
 828 A lazy attribute must have a C<default> or C<builder>. When an
 829 attribute is lazy, the default value will not be calculated until the
 830 attribute is read.
 831
 832 =item * weak_ref => $bool
 833
 834 If this is true, the attribute's value will be stored as a weak
 835 reference.
 836
 837 =item * auto_deref => $bool
 838
 839 If this is true, then the reader will dereference the value when it is
 840 called. The attribute must have a type constraint which defines the
 841 attribute as an array or hash reference.
 842
 843 =item * lazy_build => $bool
 844
 845 Setting this to true makes the attribute lazy and provides a number of
 846 default methods.
 847
 848   has 'size' => (
 849       is         => 'ro',
 850       lazy_build => 1,
 851   );
 852
 853 is equivalent to this:
 854
 855   has 'size' => (
 856       is        => 'ro',
 857       lazy      => 1,
 858       builder   => '_build_size',
 859       clearer   => 'clear_size',
 860       predicate => 'has_size',
 861   );
 862
 863 =item * documentation
 864
 865 An arbitrary string that can be retrieved later by calling C<<
 866 $attr->documentation >>.
 867
 868 =back
 869
 870 =item B<< $attr->clone(%options) >>
 871
 872 This creates a new attribute based on attribute being cloned. You must
 873 supply a C<name> option to provide a new name for the attribute.
 874
 875 The C<%options> can only specify options handled by
 876 L<Class::MOP::Attribute>.
 877
 878 =back
 879
 880 =head2 Value management
 881
 882 =over 4
 883
 884 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 885
 886 This method is used internally to initialize the attribute's slot in
 887 the object C<$instance>.
 888
 889 This overrides the L<Class::MOP::Attribute> method to handle lazy
 890 attributes, weak references, and type constraints.
 891
 892 =item B<get_value>
 893
 894 =item B<set_value>
 895
 896   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 897   if($@) {
 898     print "Oops: $@\n";
 899   }
 900
 901 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 902
 903 Before setting the value, a check is made on the type constraint of
 904 the attribute, if it has one, to see if the value passes it. If the
 905 value fails to pass, the set operation dies with a L<throw_error>.
 906
 907 Any coercion to convert values is done before checking the type constraint.
 908
 909 To check a value against a type constraint before setting it, fetch the
 910 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 911 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 912 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 913 for an example.
 914
 915 =back
 916
 917 =head2 Attribute Accessor generation
 918
 919 =over 4
 920
 921 =item B<< $attr->install_accessors >>
 922
 923 This method overrides the parent to also install delegation methods.
 924
 925 If, after installing all methods, the attribute object has no associated
 926 methods, it throws an error unless C<< is => 'bare' >> was passed to the
 927 attribute constructor.  (Trying to add an attribute that has no associated
 928 methods is almost always an error.)
 929
 930 =item B<< $attr->remove_accessors >>
 931
 932 This method overrides the parent to also remove delegation methods.
 933
 934 =item B<< $attr->install_delegation >>
 935
 936 This method adds its delegation methods to the attribute's associated
 937 class, if it has any to add.
 938
 939 =item B<< $attr->remove_delegation >>
 940
 941 This method remove its delegation methods from the attribute's
 942 associated class.
 943
 944 =item B<< $attr->accessor_metaclass >>
 945
 946 Returns the accessor metaclass name, which defaults to
 947 L<Moose::Meta::Method::Accessor>.
 948
 949 =item B<< $attr->delegation_metaclass >>
 950
 951 Returns the delegation metaclass name, which defaults to
 952 L<Moose::Meta::Method::Delegation>.
 953
 954 =back
 955
 956 =head2 Additional Moose features
 957
 958 These methods are not found in the superclass. They support features
 959 provided by Moose.
 960
 961 =over 4
 962
 963 =item B<< $attr->does($role) >>
 964
 965 This indicates whether the I<attribute itself> does the given
 966 role. The role can be given as a full class name, or as a resolvable
 967 trait name.
 968
 969 Note that this checks the attribute itself, not its type constraint,
 970 so it is checking the attribute's metaclass and any traits applied to
 971 the attribute.
 972
 973 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
 974
 975 This is an alternate constructor that handles the C<metaclass> and
 976 C<traits> options.
 977
 978 Effectively, this method is a factory that finds or creates the
 979 appropriate class for the given C<metaclass> and/or C<traits>.
 980
 981 Once it has the appropriate class, it will call C<< $class->new($name,
 982 %options) >> on that class.
 983
 984 =item B<< $attr->clone_and_inherit_options(%options) >>
 985
 986 This method supports the C<has '+foo'> feature. It does various bits
 987 of processing on the supplied C<%options> before ultimately calling
 988 the C<clone> method.
 989
 990 One of its main tasks is to make sure that the C<%options> provided
 991 only includes the options returned by the
 992 C<legal_options_for_inheritance> method.
 993
 994 =item B<< $attr->legal_options_for_inheritance >>
 995
 996 This returns a whitelist of options that can be overridden in a
 997 subclass's attribute definition.
 998
 999 This exists to allow a custom metaclass to change or add to the list
1000 of options which can be changed.
1001
1002 =item B<< $attr->type_constraint >>
1003
1004 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1005 if it has one.
1006
1007 =item B<< $attr->has_type_constraint >>
1008
1009 Returns true if this attribute has a type constraint.
1010
1011 =item B<< $attr->verify_against_type_constraint($value) >>
1012
1013 Given a value, this method returns true if the value is valid for the
1014 attribute's type constraint. If the value is not valid, it throws an
1015 error.
1016
1017 =item B<< $attr->handles >>
1018
1019 This returns the value of the C<handles> option passed to the
1020 constructor.
1021
1022 =item B<< $attr->has_handles >>
1023
1024 Returns true if this attribute performs delegation.
1025
1026 =item B<< $attr->is_weak_ref >>
1027
1028 Returns true if this attribute stores its value as a weak reference.
1029
1030 =item B<< $attr->is_required >>
1031
1032 Returns true if this attribute is required to have a value.
1033
1034 =item B<< $attr->is_lazy >>
1035
1036 Returns true if this attribute is lazy.
1037
1038 =item B<< $attr->is_lazy_build >>
1039
1040 Returns true if the C<lazy_build> option was true when passed to the
1041 constructor.
1042
1043 =item B<< $attr->should_coerce >>
1044
1045 Returns true if the C<coerce> option passed to the constructor was
1046 true.
1047
1048 =item B<< $attr->should_auto_deref >>
1049
1050 Returns true if the C<auto_deref> option passed to the constructor was
1051 true.
1052
1053 =item B<< $attr->trigger >>
1054
1055 This is the subroutine reference that was in the C<trigger> option
1056 passed to the constructor, if any.
1057
1058 =item B<< $attr->has_trigger >>
1059
1060 Returns true if this attribute has a trigger set.
1061
1062 =item B<< $attr->documentation >>
1063
1064 Returns the value that was in the C<documentation> option passed to
1065 the constructor, if any.
1066
1067 =item B<< $attr->has_documentation >>
1068
1069 Returns true if this attribute has any documentation.
1070
1071 =item B<< $attr->applied_traits >>
1072
1073 This returns an array reference of all the traits which were applied
1074 to this attribute. If none were applied, this returns C<undef>.
1075
1076 =item B<< $attr->has_applied_traits >>
1077
1078 Returns true if this attribute has any traits applied.
1079
1080 =back
1081
1082 =head1 BUGS
1083
1084 All complex software has bugs lurking in it, and this module is no
1085 exception. If you find a bug please either email me, or add the bug
1086 to cpan-RT.
1087
1088 =head1 AUTHOR
1089
1090 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1091
1092 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1093
1094 =head1 COPYRIGHT AND LICENSE
1095
1096 Copyright 2006-2009 by Infinity Interactive, Inc.
1097
1098 L<http://www.iinteractive.com>
1099
1100 This library is free software; you can redistribute it and/or modify
1101 it under the same terms as Perl itself.
1102
1103 =cut