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