lib/Moose/Meta/Attribute.pm

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