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 List::MoreUtils 'any';
   9 use Try::Tiny;
  10 use overload     ();
  11
  12 our $VERSION   = '1.17';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use Moose::Deprecated;
  16 use Moose::Meta::Method::Accessor;
  17 use Moose::Meta::Method::Delegation;
  18 use Moose::Util ();
  19 use Moose::Util::TypeConstraints ();
  20 use Class::MOP::MiniTrait;
  21
  22 use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
  23
  24 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  25
  26 __PACKAGE__->meta->add_attribute('traits' => (
  27     reader    => 'applied_traits',
  28     predicate => 'has_applied_traits',
  29 ));
  30
  31 # we need to have a ->does method in here to
  32 # more easily support traits, and the introspection
  33 # of those traits. We extend the does check to look
  34 # for metatrait aliases.
  35 sub does {
  36     my ($self, $role_name) = @_;
  37     my $name = try {
  38         Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
  39     };
  40     return 0 if !defined($name); # failed to load class
  41     return $self->Moose::Object::does($name);
  42 }
  43
  44 sub throw_error {
  45     my $self = shift;
  46     my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
  47     unshift @_, "message" if @_ % 2 == 1;
  48     unshift @_, attr => $self if ref $self;
  49     unshift @_, $class;
  50     my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1
  51     goto $handler;
  52 }
  53
  54 sub new {
  55     my ($class, $name, %options) = @_;
  56     $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
  57
  58     delete $options{__hack_no_process_options};
  59
  60     my %attrs =
  61         ( map { $_ => 1 }
  62           grep { defined }
  63           map { $_->init_arg() }
  64           $class->meta()->get_all_attributes()
  65         );
  66
  67     my @bad = sort grep { ! $attrs{$_} }  keys %options;
  68
  69     if (@bad)
  70     {
  71         Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
  72     }
  73
  74     return $class->SUPER::new($name, %options);
  75 }
  76
  77 sub interpolate_class_and_new {
  78     my ($class, $name, %args) = @_;
  79
  80     my ( $new_class, @traits ) = $class->interpolate_class(\%args);
  81
  82     $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
  83 }
  84
  85 sub interpolate_class {
  86     my ($class, $options) = @_;
  87
  88     $class = ref($class) || $class;
  89
  90     if ( my $metaclass_name = delete $options->{metaclass} ) {
  91         my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
  92
  93         if ( $class ne $new_class ) {
  94             if ( $new_class->can("interpolate_class") ) {
  95                 return $new_class->interpolate_class($options);
  96             } else {
  97                 $class = $new_class;
  98             }
  99         }
 100     }
 101
 102     my @traits;
 103
 104     if (my $traits = $options->{traits}) {
 105         my $i = 0;
 106         while ($i < @$traits) {
 107             my $trait = $traits->[$i++];
 108             next if ref($trait); # options to a trait we discarded
 109
 110             $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
 111                   || $trait;
 112
 113             next if $class->does($trait);
 114
 115             push @traits, $trait;
 116
 117             # are there options?
 118             push @traits, $traits->[$i++]
 119                 if $traits->[$i] && ref($traits->[$i]);
 120         }
 121
 122         if (@traits) {
 123             my $anon_class = Moose::Meta::Class->create_anon_class(
 124                 superclasses => [ $class ],
 125                 roles        => [ @traits ],
 126                 cache        => 1,
 127             );
 128
 129             $class = $anon_class->name;
 130         }
 131     }
 132
 133     return ( wantarray ? ( $class, @traits ) : $class );
 134 }
 135
 136 # ...
 137
 138 # method-generating options shouldn't be overridden
 139 sub illegal_options_for_inheritance {
 140     qw(reader writer accessor clearer predicate)
 141 }
 142
 143 # NOTE/TODO
 144 # This method *must* be able to handle
 145 # Class::MOP::Attribute instances as
 146 # well. Yes, I know that is wrong, but
 147 # apparently we didn't realize it was
 148 # doing that and now we have some code
 149 # which is dependent on it. The real
 150 # solution of course is to push this
 151 # feature back up into Class::MOP::Attribute
 152 # but I not right now, I am too lazy.
 153 # However if you are reading this and
 154 # looking for something to do,.. please
 155 # be my guest.
 156 # - stevan
 157 sub clone_and_inherit_options {
 158     my ($self, %options) = @_;
 159
 160     # NOTE:
 161     # we may want to extends a Class::MOP::Attribute
 162     # in which case we need to be able to use the
 163     # core set of legal options that have always
 164     # been here. But we allows Moose::Meta::Attribute
 165     # instances to changes them.
 166     # - SL
 167     my @illegal_options = $self->can('illegal_options_for_inheritance')
 168         ? $self->illegal_options_for_inheritance
 169         : ();
 170
 171     my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
 172     (scalar @found_illegal_options == 0)
 173         || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
 174
 175     if ($options{isa}) {
 176         my $type_constraint;
 177         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
 178             $type_constraint = $options{isa};
 179         }
 180         else {
 181             $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
 182             (defined $type_constraint)
 183                 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
 184         }
 185
 186         $options{type_constraint} = $type_constraint;
 187     }
 188
 189     if ($options{does}) {
 190         my $type_constraint;
 191         if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
 192             $type_constraint = $options{does};
 193         }
 194         else {
 195             $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
 196             (defined $type_constraint)
 197                 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
 198         }
 199
 200         $options{type_constraint} = $type_constraint;
 201     }
 202
 203     # NOTE:
 204     # this doesn't apply to Class::MOP::Attributes,
 205     # so we can ignore it for them.
 206     # - SL
 207     if ($self->can('interpolate_class')) {
 208         ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
 209
 210         my %seen;
 211         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
 212         $options{traits} = \@all_traits if @all_traits;
 213     }
 214
 215     $self->_modify_attr_options_for_lazy_build( $self->name, \%options );
 216
 217     $self->clone(%options);
 218 }
 219
 220 sub clone {
 221     my ( $self, %params ) = @_;
 222
 223     my $class = delete $params{metaclass} || ref $self;
 224
 225     my ( @init, @non_init );
 226
 227     foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
 228         push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
 229     }
 230
 231     my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
 232
 233     my $name = delete $new_params{name};
 234
 235     my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
 236
 237     foreach my $attr ( @non_init ) {
 238         $attr->set_value($clone, $attr->get_value($self));
 239     }
 240
 241     return $clone;
 242 }
 243
 244 sub _process_options {
 245     my ($class, $name, $options) = @_;
 246
 247     if (exists $options->{is}) {
 248
 249         ### -------------------------
 250         ## is => ro, writer => _foo    # turns into (reader => foo, writer => _foo) as before
 251         ## is => rw, writer => _foo    # turns into (reader => foo, writer => _foo)
 252         ## is => rw, accessor => _foo  # turns into (accessor => _foo)
 253         ## is => ro, accessor => _foo  # error, accesor is rw
 254         ### -------------------------
 255
 256         if ($options->{is} eq 'ro') {
 257             $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
 258                 if exists $options->{accessor};
 259             $options->{reader} ||= $name;
 260         }
 261         elsif ($options->{is} eq 'rw') {
 262             if ($options->{writer}) {
 263                 $options->{reader} ||= $name;
 264             }
 265             else {
 266                 $options->{accessor} ||= $name;
 267             }
 268         }
 269         elsif ($options->{is} eq 'bare') {
 270             # do nothing, but don't complain (later) about missing methods
 271         }
 272         else {
 273             $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
 274         }
 275     }
 276
 277     if (exists $options->{isa}) {
 278         if (exists $options->{does}) {
 279             if (try { $options->{isa}->can('does') }) {
 280                 ($options->{isa}->does($options->{does}))
 281                     || $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);
 282             }
 283             else {
 284                 $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
 285             }
 286         }
 287
 288         # allow for anon-subtypes here ...
 289         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 290             $options->{type_constraint} = $options->{isa};
 291         }
 292         else {
 293             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
 294         }
 295     }
 296     elsif (exists $options->{does}) {
 297         # allow for anon-subtypes here ...
 298         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 299                 $options->{type_constraint} = $options->{does};
 300         }
 301         else {
 302             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
 303         }
 304     }
 305
 306     if (exists $options->{coerce} && $options->{coerce}) {
 307         (exists $options->{type_constraint})
 308             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options);
 309         $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options)
 310             if $options->{weak_ref};
 311
 312         unless ( $options->{type_constraint}->has_coercion ) {
 313             my $type = $options->{type_constraint}->name;
 314
 315             Moose::Deprecated::deprecated(
 316                 feature => 'coerce without coercion',
 317                 message =>
 318                     "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
 319             );
 320         }
 321     }
 322
 323     if (exists $options->{trigger}) {
 324         ('CODE' eq ref $options->{trigger})
 325             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
 326     }
 327
 328     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 329         (exists $options->{type_constraint})
 330             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options);
 331         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 332          $options->{type_constraint}->is_a_type_of('HashRef'))
 333             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options);
 334     }
 335
 336     $class->_modify_attr_options_for_lazy_build( $name, $options );
 337
 338     if (exists $options->{lazy} && $options->{lazy}) {
 339         (exists $options->{default} || defined $options->{builder} )
 340             || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
 341     }
 342
 343     if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
 344         $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
 345     }
 346
 347 }
 348
 349 sub _modify_attr_options_for_lazy_build {
 350     my ( $class, $name, $options ) = @_;
 351
 352     return unless $options->{lazy_build};
 353
 354     $class->throw_error(
 355         "You can not use lazy_build and default for the same attribute ($name)",
 356         data => $options )
 357         if exists $options->{default};
 358
 359     $options->{lazy} = 1;
 360     $options->{builder} ||= "_build_${name}";
 361     if ( $name =~ /^_/ ) {
 362         $options->{clearer}   ||= "_clear${name}";
 363         $options->{predicate} ||= "_has${name}";
 364     }
 365     else {
 366         $options->{clearer}   ||= "clear_${name}";
 367         $options->{predicate} ||= "has_${name}";
 368     }
 369 }
 370
 371 sub initialize_instance_slot {
 372     my ($self, $meta_instance, $instance, $params) = @_;
 373     my $init_arg = $self->init_arg();
 374     # try to fetch the init arg from the %params ...
 375
 376     my $val;
 377     my $value_is_set;
 378     if ( defined($init_arg) and exists $params->{$init_arg}) {
 379         $val = $params->{$init_arg};
 380         $value_is_set = 1;
 381     }
 382     else {
 383         # skip it if it's lazy
 384         return if $self->is_lazy;
 385         # and die if it's required and doesn't have a default value
 386         $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
 387             if $self->is_required && !$self->has_default && !$self->has_builder;
 388
 389         # if nothing was in the %params, we can use the
 390         # attribute's default value (if it has one)
 391         if ($self->has_default) {
 392             $val = $self->default($instance);
 393             $value_is_set = 1;
 394         }
 395         elsif ($self->has_builder) {
 396             $val = $self->_call_builder($instance);
 397             $value_is_set = 1;
 398         }
 399     }
 400
 401     return unless $value_is_set;
 402
 403     $val = $self->_coerce_and_verify( $val, $instance );
 404
 405     $self->set_initial_value($instance, $val);
 406
 407     if ( ref $val && $self->is_weak_ref ) {
 408         $self->_weaken_value($instance);
 409     }
 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 $callback = sub {
 446         my $val = $self->_coerce_and_verify( shift, $instance );;
 447
 448         $meta_instance->set_slot_value($instance, $slot_name, $val);
 449     };
 450
 451     my $initializer = $self->initializer;
 452
 453     # most things will just want to set a value, so make it first arg
 454     $instance->$initializer($value, $callback, $self);
 455 }
 456
 457 sub set_value {
 458     my ($self, $instance, @args) = @_;
 459     my $value = $args[0];
 460
 461     my $attr_name = $self->name;
 462
 463     if ($self->is_required and not @args) {
 464         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
 465     }
 466
 467     $value = $self->_coerce_and_verify( $value, $instance );
 468
 469     my @old;
 470     if ( $self->has_trigger && $self->has_value($instance) ) {
 471         @old = $self->get_value($instance, 'for trigger');
 472     }
 473
 474     $self->SUPER::set_value($instance, $value);
 475
 476     if ( ref $value && $self->is_weak_ref ) {
 477         $self->_weaken_value($instance);
 478     }
 479
 480     if ($self->has_trigger) {
 481         $self->trigger->($instance, $value, @old);
 482     }
 483 }
 484
 485 sub _weaken_value {
 486     my ( $self, $instance ) = @_;
 487
 488     my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
 489         ->get_meta_instance;
 490
 491     $meta_instance->weaken_slot_value( $instance, $self->name );
 492 }
 493
 494 sub get_value {
 495     my ($self, $instance, $for_trigger) = @_;
 496
 497     if ($self->is_lazy) {
 498         unless ($self->has_value($instance)) {
 499             my $value;
 500             if ($self->has_default) {
 501                 $value = $self->default($instance);
 502             } elsif ( $self->has_builder ) {
 503                 $value = $self->_call_builder($instance);
 504             }
 505
 506             $value = $self->_coerce_and_verify( $value, $instance );
 507
 508             $self->set_initial_value($instance, $value);
 509         }
 510     }
 511
 512     if ( $self->should_auto_deref && ! $for_trigger ) {
 513
 514         my $type_constraint = $self->type_constraint;
 515
 516         if ($type_constraint->is_a_type_of('ArrayRef')) {
 517             my $rv = $self->SUPER::get_value($instance);
 518             return unless defined $rv;
 519             return wantarray ? @{ $rv } : $rv;
 520         }
 521         elsif ($type_constraint->is_a_type_of('HashRef')) {
 522             my $rv = $self->SUPER::get_value($instance);
 523             return unless defined $rv;
 524             return wantarray ? %{ $rv } : $rv;
 525         }
 526         else {
 527             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
 528         }
 529
 530     }
 531     else {
 532
 533         return $self->SUPER::get_value($instance);
 534     }
 535 }
 536
 537 ## installing accessors
 538
 539 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 540
 541 sub install_accessors {
 542     my $self = shift;
 543     $self->SUPER::install_accessors(@_);
 544     $self->install_delegation if $self->has_handles;
 545     return;
 546 }
 547
 548 sub _check_associated_methods {
 549     my $self = shift;
 550     unless (
 551         @{ $self->associated_methods }
 552         || ($self->_is_metadata || '') eq 'bare'
 553     ) {
 554         Carp::cluck(
 555             'Attribute (' . $self->name . ') of class '
 556             . $self->associated_class->name
 557             . ' has no associated methods'
 558             . ' (did you mean to provide an "is" argument?)'
 559             . "\n"
 560         )
 561     }
 562 }
 563
 564 sub _process_accessors {
 565     my $self = shift;
 566     my ($type, $accessor, $generate_as_inline_methods) = @_;
 567     $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH';
 568     my $method = $self->associated_class->get_method($accessor);
 569     if ($method && !$method->isa('Class::MOP::Method::Accessor')
 570      && (!$self->definition_context
 571       || $method->package_name eq $self->definition_context->{package})) {
 572         Carp::cluck(
 573             "You are overwriting a locally defined method ($accessor) with "
 574           . "an accessor"
 575         );
 576     }
 577     if (!$self->associated_class->has_method($accessor)
 578      && $self->associated_class->has_package_symbol('&' . $accessor)) {
 579         Carp::cluck(
 580             "You are overwriting a locally defined function ($accessor) with "
 581           . "an accessor"
 582         );
 583     }
 584     $self->SUPER::_process_accessors(@_);
 585 }
 586
 587 sub remove_accessors {
 588     my $self = shift;
 589     $self->SUPER::remove_accessors(@_);
 590     $self->remove_delegation if $self->has_handles;
 591     return;
 592 }
 593
 594 sub inline_set {
 595     my $self = shift;
 596     my ( $instance, $value ) = @_;
 597
 598     my $mi = $self->associated_class->get_meta_instance;
 599
 600     my $code
 601         = $mi->inline_set_slot_value( $instance, $self->slots, $value ) . ";";
 602     $code
 603         .= $mi->inline_weaken_slot_value( $instance, $self->slots, $value )
 604         . "    if ref $value;"
 605         if $self->is_weak_ref;
 606
 607     return $code;
 608 }
 609
 610 sub install_delegation {
 611     my $self = shift;
 612
 613     # NOTE:
 614     # Here we canonicalize the 'handles' option
 615     # this will sort out any details and always
 616     # return an hash of methods which we want
 617     # to delagate to, see that method for details
 618     my %handles = $self->_canonicalize_handles;
 619
 620
 621     # install the delegation ...
 622     my $associated_class = $self->associated_class;
 623     foreach my $handle (keys %handles) {
 624         my $method_to_call = $handles{$handle};
 625         my $class_name = $associated_class->name;
 626         my $name = "${class_name}::${handle}";
 627
 628             (!$associated_class->has_method($handle))
 629                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 630
 631         # NOTE:
 632         # handles is not allowed to delegate
 633         # any of these methods, as they will
 634         # override the ones in your class, which
 635         # is almost certainly not what you want.
 636
 637         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 638         #cluck("Not delegating method '$handle' because it is a core method") and
 639         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 640
 641         my $method = $self->_make_delegation_method($handle, $method_to_call);
 642
 643         $self->associated_class->add_method($method->name, $method);
 644         $self->associate_method($method);
 645     }
 646 }
 647
 648 sub remove_delegation {
 649     my $self = shift;
 650     my %handles = $self->_canonicalize_handles;
 651     my $associated_class = $self->associated_class;
 652     foreach my $handle (keys %handles) {
 653         next unless any { $handle eq $_ }
 654                     map { $_->name }
 655                     @{ $self->associated_methods };
 656         $self->associated_class->remove_method($handle);
 657     }
 658 }
 659
 660 # private methods to help delegation ...
 661
 662 sub _canonicalize_handles {
 663     my $self    = shift;
 664     my $handles = $self->handles;
 665     if (my $handle_type = ref($handles)) {
 666         if ($handle_type eq 'HASH') {
 667             return %{$handles};
 668         }
 669         elsif ($handle_type eq 'ARRAY') {
 670             return map { $_ => $_ } @{$handles};
 671         }
 672         elsif ($handle_type eq 'Regexp') {
 673             ($self->has_type_constraint)
 674                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 675             return map  { ($_ => $_) }
 676                    grep { /$handles/ } $self->_get_delegate_method_list;
 677         }
 678         elsif ($handle_type eq 'CODE') {
 679             return $handles->($self, $self->_find_delegate_metaclass);
 680         }
 681         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
 682             return map { $_ => $_ } @{ $handles->methods };
 683         }
 684         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
 685             $handles = $handles->role;
 686         }
 687         else {
 688             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 689         }
 690     }
 691
 692     Class::MOP::load_class($handles);
 693     my $role_meta = Class::MOP::class_of($handles);
 694
 695     (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 696         || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 697
 698     return map { $_ => $_ }
 699         map { $_->name }
 700         grep { !$_->isa('Class::MOP::Method::Meta') } (
 701         $role_meta->_get_local_methods,
 702         $role_meta->get_required_method_list,
 703         );
 704 }
 705
 706 sub _get_delegate_method_list {
 707     my $self = shift;
 708     my $meta = $self->_find_delegate_metaclass;
 709     if ($meta->isa('Class::MOP::Class')) {
 710         return map  { $_->name }  # NOTE: !never! delegate &meta
 711                grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
 712                     $meta->get_all_methods;
 713     }
 714     elsif ($meta->isa('Moose::Meta::Role')) {
 715         return $meta->get_method_list;
 716     }
 717     else {
 718         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 719     }
 720 }
 721
 722 sub _find_delegate_metaclass {
 723     my $self = shift;
 724     if (my $class = $self->_isa_metadata) {
 725         # we might be dealing with a non-Moose class,
 726         # and need to make our own metaclass. if there's
 727         # already a metaclass, it will be returned
 728         return Class::MOP::Class->initialize($class);
 729     }
 730     elsif (my $role = $self->_does_metadata) {
 731         return Class::MOP::class_of($role);
 732     }
 733     else {
 734         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 735     }
 736 }
 737
 738 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 739
 740 sub _make_delegation_method {
 741     my ( $self, $handle_name, $method_to_call ) = @_;
 742
 743     my @curried_arguments;
 744
 745     ($method_to_call, @curried_arguments) = @$method_to_call
 746         if 'ARRAY' eq ref($method_to_call);
 747
 748     return $self->delegation_metaclass->new(
 749         name               => $handle_name,
 750         package_name       => $self->associated_class->name,
 751         attribute          => $self,
 752         delegate_to_method => $method_to_call,
 753         curried_arguments  => \@curried_arguments,
 754     );
 755 }
 756
 757 sub _coerce_and_verify {
 758     my $self     = shift;
 759     my $val      = shift;
 760     my $instance = shift;
 761
 762     return $val unless $self->has_type_constraint;
 763
 764     $val = $self->type_constraint->coerce($val)
 765         if $self->should_coerce && $self->type_constraint->has_coercion;
 766
 767     $self->verify_against_type_constraint($val, instance => $instance);
 768
 769     return $val;
 770 }
 771
 772 sub verify_against_type_constraint {
 773     my $self = shift;
 774     my $val  = shift;
 775
 776     return 1 if !$self->has_type_constraint;
 777
 778     my $type_constraint = $self->type_constraint;
 779
 780     $type_constraint->check($val)
 781         || $self->throw_error("Attribute ("
 782                  . $self->name
 783                  . ") does not pass the type constraint because: "
 784                  . $type_constraint->get_message($val), data => $val, @_);
 785 }
 786
 787 package Moose::Meta::Attribute::Custom::Moose;
 788 sub register_implementation { 'Moose::Meta::Attribute' }
 789
 790 1;
 791
 792 __END__
 793
 794 =pod
 795
 796 =head1 NAME
 797
 798 Moose::Meta::Attribute - The Moose attribute metaclass
 799
 800 =head1 DESCRIPTION
 801
 802 This class is a subclass of L<Class::MOP::Attribute> that provides
 803 additional Moose-specific functionality.
 804
 805 To really understand this class, you will need to start with the
 806 L<Class::MOP::Attribute> documentation. This class can be understood
 807 as a set of additional features on top of the basic feature provided
 808 by that parent class.
 809
 810 =head1 INHERITANCE
 811
 812 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 813
 814 =head1 METHODS
 815
 816 Many of the documented below override methods in
 817 L<Class::MOP::Attribute> and add Moose specific features.
 818
 819 =head2 Creation
 820
 821 =over 4
 822
 823 =item B<< Moose::Meta::Attribute->new(%options) >>
 824
 825 This method overrides the L<Class::MOP::Attribute> constructor.
 826
 827 Many of the options below are described in more detail in the
 828 L<Moose::Manual::Attributes> document.
 829
 830 It adds the following options to the constructor:
 831
 832 =over 8
 833
 834 =item * is => 'ro', 'rw', 'bare'
 835
 836 This provides a shorthand for specifying the C<reader>, C<writer>, or
 837 C<accessor> names. If the attribute is read-only ('ro') then it will
 838 have a C<reader> method with the same attribute as the name.
 839
 840 If it is read-write ('rw') then it will have an C<accessor> method
 841 with the same name. If you provide an explicit C<writer> for a
 842 read-write attribute, then you will have a C<reader> with the same
 843 name as the attribute, and a C<writer> with the name you provided.
 844
 845 Use 'bare' when you are deliberately not installing any methods
 846 (accessor, reader, etc.) associated with this attribute; otherwise,
 847 Moose will issue a deprecation warning when this attribute is added to a
 848 metaclass.
 849
 850 =item * isa => $type
 851
 852 This option accepts a type. The type can be a string, which should be
 853 a type name. If the type name is unknown, it is assumed to be a class
 854 name.
 855
 856 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 857
 858 If you I<also> provide a C<does> option, then your C<isa> option must
 859 be a class name, and that class must do the role specified with
 860 C<does>.
 861
 862 =item * does => $role
 863
 864 This is short-hand for saying that the attribute's type must be an
 865 object which does the named role.
 866
 867 =item * coerce => $bool
 868
 869 This option is only valid for objects with a type constraint
 870 (C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
 871 this attribute is set.
 872
 873 You can make both this and the C<weak_ref> option true.
 874
 875 =item * trigger => $sub
 876
 877 This option accepts a subroutine reference, which will be called after
 878 the attribute is set.
 879
 880 =item * required => $bool
 881
 882 An attribute which is required must be provided to the constructor. An
 883 attribute which is required can also have a C<default> or C<builder>,
 884 which will satisfy its required-ness.
 885
 886 A required attribute must have a C<default>, C<builder> or a
 887 non-C<undef> C<init_arg>
 888
 889 =item * lazy => $bool
 890
 891 A lazy attribute must have a C<default> or C<builder>. When an
 892 attribute is lazy, the default value will not be calculated until the
 893 attribute is read.
 894
 895 =item * weak_ref => $bool
 896
 897 If this is true, the attribute's value will be stored as a weak
 898 reference.
 899
 900 =item * auto_deref => $bool
 901
 902 If this is true, then the reader will dereference the value when it is
 903 called. The attribute must have a type constraint which defines the
 904 attribute as an array or hash reference.
 905
 906 =item * lazy_build => $bool
 907
 908 Setting this to true makes the attribute lazy and provides a number of
 909 default methods.
 910
 911   has 'size' => (
 912       is         => 'ro',
 913       lazy_build => 1,
 914   );
 915
 916 is equivalent to this:
 917
 918   has 'size' => (
 919       is        => 'ro',
 920       lazy      => 1,
 921       builder   => '_build_size',
 922       clearer   => 'clear_size',
 923       predicate => 'has_size',
 924   );
 925
 926 =item * documentation
 927
 928 An arbitrary string that can be retrieved later by calling C<<
 929 $attr->documentation >>.
 930
 931 =back
 932
 933 =item B<< $attr->clone(%options) >>
 934
 935 This creates a new attribute based on attribute being cloned. You must
 936 supply a C<name> option to provide a new name for the attribute.
 937
 938 The C<%options> can only specify options handled by
 939 L<Class::MOP::Attribute>.
 940
 941 =back
 942
 943 =head2 Value management
 944
 945 =over 4
 946
 947 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 948
 949 This method is used internally to initialize the attribute's slot in
 950 the object C<$instance>.
 951
 952 This overrides the L<Class::MOP::Attribute> method to handle lazy
 953 attributes, weak references, and type constraints.
 954
 955 =item B<get_value>
 956
 957 =item B<set_value>
 958
 959   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 960   if($@) {
 961     print "Oops: $@\n";
 962   }
 963
 964 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 965
 966 Before setting the value, a check is made on the type constraint of
 967 the attribute, if it has one, to see if the value passes it. If the
 968 value fails to pass, the set operation dies with a L</throw_error>.
 969
 970 Any coercion to convert values is done before checking the type constraint.
 971
 972 To check a value against a type constraint before setting it, fetch the
 973 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 974 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 975 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 976 for an example.
 977
 978 =back
 979
 980 =head2 Attribute Accessor generation
 981
 982 =over 4
 983
 984 =item B<< $attr->install_accessors >>
 985
 986 This method overrides the parent to also install delegation methods.
 987
 988 If, after installing all methods, the attribute object has no associated
 989 methods, it throws an error unless C<< is => 'bare' >> was passed to the
 990 attribute constructor.  (Trying to add an attribute that has no associated
 991 methods is almost always an error.)
 992
 993 =item B<< $attr->remove_accessors >>
 994
 995 This method overrides the parent to also remove delegation methods.
 996
 997 =item B<< $attr->inline_set($instance_var, $value_var) >>
 998
 999 This method return a code snippet suitable for inlining the relevant
1000 operation. It expect strings containing variable names to be used in the
1001 inlining, like C<'$self'> or C<'$_[1]'>.
1002
1003 =item B<< $attr->install_delegation >>
1004
1005 This method adds its delegation methods to the attribute's associated
1006 class, if it has any to add.
1007
1008 =item B<< $attr->remove_delegation >>
1009
1010 This method remove its delegation methods from the attribute's
1011 associated class.
1012
1013 =item B<< $attr->accessor_metaclass >>
1014
1015 Returns the accessor metaclass name, which defaults to
1016 L<Moose::Meta::Method::Accessor>.
1017
1018 =item B<< $attr->delegation_metaclass >>
1019
1020 Returns the delegation metaclass name, which defaults to
1021 L<Moose::Meta::Method::Delegation>.
1022
1023 =back
1024
1025 =head2 Additional Moose features
1026
1027 These methods are not found in the superclass. They support features
1028 provided by Moose.
1029
1030 =over 4
1031
1032 =item B<< $attr->does($role) >>
1033
1034 This indicates whether the I<attribute itself> does the given
1035 role. The role can be given as a full class name, or as a resolvable
1036 trait name.
1037
1038 Note that this checks the attribute itself, not its type constraint,
1039 so it is checking the attribute's metaclass and any traits applied to
1040 the attribute.
1041
1042 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1043
1044 This is an alternate constructor that handles the C<metaclass> and
1045 C<traits> options.
1046
1047 Effectively, this method is a factory that finds or creates the
1048 appropriate class for the given C<metaclass> and/or C<traits>.
1049
1050 Once it has the appropriate class, it will call C<< $class->new($name,
1051 %options) >> on that class.
1052
1053 =item B<< $attr->clone_and_inherit_options(%options) >>
1054
1055 This method supports the C<has '+foo'> feature. It does various bits
1056 of processing on the supplied C<%options> before ultimately calling
1057 the C<clone> method.
1058
1059 One of its main tasks is to make sure that the C<%options> provided
1060 does not include the options returned by the
1061 C<illegal_options_for_inheritance> method.
1062
1063 =item B<< $attr->illegal_options_for_inheritance >>
1064
1065 This returns a blacklist of options that can not be overridden in a
1066 subclass's attribute definition.
1067
1068 This exists to allow a custom metaclass to change or add to the list
1069 of options which can not be changed.
1070
1071 =item B<< $attr->type_constraint >>
1072
1073 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1074 if it has one.
1075
1076 =item B<< $attr->has_type_constraint >>
1077
1078 Returns true if this attribute has a type constraint.
1079
1080 =item B<< $attr->verify_against_type_constraint($value) >>
1081
1082 Given a value, this method returns true if the value is valid for the
1083 attribute's type constraint. If the value is not valid, it throws an
1084 error.
1085
1086 =item B<< $attr->handles >>
1087
1088 This returns the value of the C<handles> option passed to the
1089 constructor.
1090
1091 =item B<< $attr->has_handles >>
1092
1093 Returns true if this attribute performs delegation.
1094
1095 =item B<< $attr->is_weak_ref >>
1096
1097 Returns true if this attribute stores its value as a weak reference.
1098
1099 =item B<< $attr->is_required >>
1100
1101 Returns true if this attribute is required to have a value.
1102
1103 =item B<< $attr->is_lazy >>
1104
1105 Returns true if this attribute is lazy.
1106
1107 =item B<< $attr->is_lazy_build >>
1108
1109 Returns true if the C<lazy_build> option was true when passed to the
1110 constructor.
1111
1112 =item B<< $attr->should_coerce >>
1113
1114 Returns true if the C<coerce> option passed to the constructor was
1115 true.
1116
1117 =item B<< $attr->should_auto_deref >>
1118
1119 Returns true if the C<auto_deref> option passed to the constructor was
1120 true.
1121
1122 =item B<< $attr->trigger >>
1123
1124 This is the subroutine reference that was in the C<trigger> option
1125 passed to the constructor, if any.
1126
1127 =item B<< $attr->has_trigger >>
1128
1129 Returns true if this attribute has a trigger set.
1130
1131 =item B<< $attr->documentation >>
1132
1133 Returns the value that was in the C<documentation> option passed to
1134 the constructor, if any.
1135
1136 =item B<< $attr->has_documentation >>
1137
1138 Returns true if this attribute has any documentation.
1139
1140 =item B<< $attr->applied_traits >>
1141
1142 This returns an array reference of all the traits which were applied
1143 to this attribute. If none were applied, this returns C<undef>.
1144
1145 =item B<< $attr->has_applied_traits >>
1146
1147 Returns true if this attribute has any traits applied.
1148
1149 =back
1150
1151 =head1 BUGS
1152
1153 See L<Moose/BUGS> for details on reporting bugs.
1154
1155 =head1 AUTHOR
1156
1157 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1158
1159 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1160
1161 =head1 COPYRIGHT AND LICENSE
1162
1163 Copyright 2006-2010 by Infinity Interactive, Inc.
1164
1165 L<http://www.iinteractive.com>
1166
1167 This library is free software; you can redistribute it and/or modify
1168 it under the same terms as Perl itself.
1169
1170 =cut