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