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.09';
  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(is 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 install_delegation {
 581     my $self = shift;
 582
 583     # NOTE:
 584     # Here we canonicalize the 'handles' option
 585     # this will sort out any details and always
 586     # return an hash of methods which we want
 587     # to delagate to, see that method for details
 588     my %handles = $self->_canonicalize_handles;
 589
 590
 591     # install the delegation ...
 592     my $associated_class = $self->associated_class;
 593     foreach my $handle (keys %handles) {
 594         my $method_to_call = $handles{$handle};
 595         my $class_name = $associated_class->name;
 596         my $name = "${class_name}::${handle}";
 597
 598             (!$associated_class->has_method($handle))
 599                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 600
 601         # NOTE:
 602         # handles is not allowed to delegate
 603         # any of these methods, as they will
 604         # override the ones in your class, which
 605         # is almost certainly not what you want.
 606
 607         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 608         #cluck("Not delegating method '$handle' because it is a core method") and
 609         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 610
 611         my $method = $self->_make_delegation_method($handle, $method_to_call);
 612
 613         $self->associated_class->add_method($method->name, $method);
 614         $self->associate_method($method);
 615     }
 616 }
 617
 618 sub remove_delegation {
 619     my $self = shift;
 620     my %handles = $self->_canonicalize_handles;
 621     my $associated_class = $self->associated_class;
 622     foreach my $handle (keys %handles) {
 623         next unless any { $handle eq $_ }
 624                     map { $_->name }
 625                     @{ $self->associated_methods };
 626         $self->associated_class->remove_method($handle);
 627     }
 628 }
 629
 630 # private methods to help delegation ...
 631
 632 sub _canonicalize_handles {
 633     my $self    = shift;
 634     my $handles = $self->handles;
 635     if (my $handle_type = ref($handles)) {
 636         if ($handle_type eq 'HASH') {
 637             return %{$handles};
 638         }
 639         elsif ($handle_type eq 'ARRAY') {
 640             return map { $_ => $_ } @{$handles};
 641         }
 642         elsif ($handle_type eq 'Regexp') {
 643             ($self->has_type_constraint)
 644                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 645             return map  { ($_ => $_) }
 646                    grep { /$handles/ } $self->_get_delegate_method_list;
 647         }
 648         elsif ($handle_type eq 'CODE') {
 649             return $handles->($self, $self->_find_delegate_metaclass);
 650         }
 651         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
 652             return map { $_ => $_ } @{ $handles->methods };
 653         }
 654         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
 655             $handles = $handles->role;
 656         }
 657         else {
 658             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 659         }
 660     }
 661
 662     Class::MOP::load_class($handles);
 663     my $role_meta = Class::MOP::class_of($handles);
 664
 665     (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 666         || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 667
 668     return map { $_ => $_ }
 669         grep { $_ ne 'meta' } (
 670         $role_meta->get_method_list,
 671         map { $_->name } $role_meta->get_required_method_list,
 672         );
 673 }
 674
 675 sub _find_delegate_metaclass {
 676     my $self = shift;
 677     if (my $class = $self->_isa_metadata) {
 678         # we might be dealing with a non-Moose class,
 679         # and need to make our own metaclass. if there's
 680         # already a metaclass, it will be returned
 681         return Class::MOP::Class->initialize($class);
 682     }
 683     elsif (my $role = $self->_does_metadata) {
 684         return Class::MOP::class_of($role);
 685     }
 686     else {
 687         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 688     }
 689 }
 690
 691 sub _get_delegate_method_list {
 692     my $self = shift;
 693     my $meta = $self->_find_delegate_metaclass;
 694     if ($meta->isa('Class::MOP::Class')) {
 695         return map  { $_->name }  # NOTE: !never! delegate &meta
 696                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 697                     $meta->get_all_methods;
 698     }
 699     elsif ($meta->isa('Moose::Meta::Role')) {
 700         return $meta->get_method_list;
 701     }
 702     else {
 703         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 704     }
 705 }
 706
 707 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 708
 709 sub _make_delegation_method {
 710     my ( $self, $handle_name, $method_to_call ) = @_;
 711
 712     my @curried_arguments;
 713
 714     ($method_to_call, @curried_arguments) = @$method_to_call
 715         if 'ARRAY' eq ref($method_to_call);
 716
 717     return $self->delegation_metaclass->new(
 718         name               => $handle_name,
 719         package_name       => $self->associated_class->name,
 720         attribute          => $self,
 721         delegate_to_method => $method_to_call,
 722         curried_arguments  => \@curried_arguments,
 723     );
 724 }
 725
 726 sub _coerce_and_verify {
 727     my $self     = shift;
 728     my $val      = shift;
 729     my $instance = shift;
 730
 731     return $val unless $self->has_type_constraint;
 732
 733     $val = $self->type_constraint->coerce($val)
 734         if $self->should_coerce && $self->type_constraint->has_coercion;
 735
 736     $self->verify_against_type_constraint($val, instance => $instance);
 737
 738     return $val;
 739 }
 740
 741 sub verify_against_type_constraint {
 742     my $self = shift;
 743     my $val  = shift;
 744
 745     return 1 if !$self->has_type_constraint;
 746
 747     my $type_constraint = $self->type_constraint;
 748
 749     $type_constraint->check($val)
 750         || $self->throw_error("Attribute ("
 751                  . $self->name
 752                  . ") does not pass the type constraint because: "
 753                  . $type_constraint->get_message($val), data => $val, @_);
 754 }
 755
 756 package Moose::Meta::Attribute::Custom::Moose;
 757 sub register_implementation { 'Moose::Meta::Attribute' }
 758
 759 1;
 760
 761 __END__
 762
 763 =pod
 764
 765 =head1 NAME
 766
 767 Moose::Meta::Attribute - The Moose attribute metaclass
 768
 769 =head1 DESCRIPTION
 770
 771 This class is a subclass of L<Class::MOP::Attribute> that provides
 772 additional Moose-specific functionality.
 773
 774 To really understand this class, you will need to start with the
 775 L<Class::MOP::Attribute> documentation. This class can be understood
 776 as a set of additional features on top of the basic feature provided
 777 by that parent class.
 778
 779 =head1 INHERITANCE
 780
 781 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 782
 783 =head1 METHODS
 784
 785 Many of the documented below override methods in
 786 L<Class::MOP::Attribute> and add Moose specific features.
 787
 788 =head2 Creation
 789
 790 =over 4
 791
 792 =item B<< Moose::Meta::Attribute->new(%options) >>
 793
 794 This method overrides the L<Class::MOP::Attribute> constructor.
 795
 796 Many of the options below are described in more detail in the
 797 L<Moose::Manual::Attributes> document.
 798
 799 It adds the following options to the constructor:
 800
 801 =over 8
 802
 803 =item * is => 'ro', 'rw', 'bare'
 804
 805 This provides a shorthand for specifying the C<reader>, C<writer>, or
 806 C<accessor> names. If the attribute is read-only ('ro') then it will
 807 have a C<reader> method with the same attribute as the name.
 808
 809 If it is read-write ('rw') then it will have an C<accessor> method
 810 with the same name. If you provide an explicit C<writer> for a
 811 read-write attribute, then you will have a C<reader> with the same
 812 name as the attribute, and a C<writer> with the name you provided.
 813
 814 Use 'bare' when you are deliberately not installing any methods
 815 (accessor, reader, etc.) associated with this attribute; otherwise,
 816 Moose will issue a deprecation warning when this attribute is added to a
 817 metaclass.
 818
 819 =item * isa => $type
 820
 821 This option accepts a type. The type can be a string, which should be
 822 a type name. If the type name is unknown, it is assumed to be a class
 823 name.
 824
 825 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 826
 827 If you I<also> provide a C<does> option, then your C<isa> option must
 828 be a class name, and that class must do the role specified with
 829 C<does>.
 830
 831 =item * does => $role
 832
 833 This is short-hand for saying that the attribute's type must be an
 834 object which does the named role.
 835
 836 =item * coerce => $bool
 837
 838 This option is only valid for objects with a type constraint
 839 (C<isa>). If this is true, then coercions will be applied whenever
 840 this attribute is set.
 841
 842 You can make both this and the C<weak_ref> option true.
 843
 844 =item * trigger => $sub
 845
 846 This option accepts a subroutine reference, which will be called after
 847 the attribute is set.
 848
 849 =item * required => $bool
 850
 851 An attribute which is required must be provided to the constructor. An
 852 attribute which is required can also have a C<default> or C<builder>,
 853 which will satisfy its required-ness.
 854
 855 A required attribute must have a C<default>, C<builder> or a
 856 non-C<undef> C<init_arg>
 857
 858 =item * lazy => $bool
 859
 860 A lazy attribute must have a C<default> or C<builder>. When an
 861 attribute is lazy, the default value will not be calculated until the
 862 attribute is read.
 863
 864 =item * weak_ref => $bool
 865
 866 If this is true, the attribute's value will be stored as a weak
 867 reference.
 868
 869 =item * auto_deref => $bool
 870
 871 If this is true, then the reader will dereference the value when it is
 872 called. The attribute must have a type constraint which defines the
 873 attribute as an array or hash reference.
 874
 875 =item * lazy_build => $bool
 876
 877 Setting this to true makes the attribute lazy and provides a number of
 878 default methods.
 879
 880   has 'size' => (
 881       is         => 'ro',
 882       lazy_build => 1,
 883   );
 884
 885 is equivalent to this:
 886
 887   has 'size' => (
 888       is        => 'ro',
 889       lazy      => 1,
 890       builder   => '_build_size',
 891       clearer   => 'clear_size',
 892       predicate => 'has_size',
 893   );
 894
 895 =item * documentation
 896
 897 An arbitrary string that can be retrieved later by calling C<<
 898 $attr->documentation >>.
 899
 900 =back
 901
 902 =item B<< $attr->clone(%options) >>
 903
 904 This creates a new attribute based on attribute being cloned. You must
 905 supply a C<name> option to provide a new name for the attribute.
 906
 907 The C<%options> can only specify options handled by
 908 L<Class::MOP::Attribute>.
 909
 910 =back
 911
 912 =head2 Value management
 913
 914 =over 4
 915
 916 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 917
 918 This method is used internally to initialize the attribute's slot in
 919 the object C<$instance>.
 920
 921 This overrides the L<Class::MOP::Attribute> method to handle lazy
 922 attributes, weak references, and type constraints.
 923
 924 =item B<get_value>
 925
 926 =item B<set_value>
 927
 928   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 929   if($@) {
 930     print "Oops: $@\n";
 931   }
 932
 933 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 934
 935 Before setting the value, a check is made on the type constraint of
 936 the attribute, if it has one, to see if the value passes it. If the
 937 value fails to pass, the set operation dies with a L</throw_error>.
 938
 939 Any coercion to convert values is done before checking the type constraint.
 940
 941 To check a value against a type constraint before setting it, fetch the
 942 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 943 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 944 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 945 for an example.
 946
 947 =back
 948
 949 =head2 Attribute Accessor generation
 950
 951 =over 4
 952
 953 =item B<< $attr->install_accessors >>
 954
 955 This method overrides the parent to also install delegation methods.
 956
 957 If, after installing all methods, the attribute object has no associated
 958 methods, it throws an error unless C<< is => 'bare' >> was passed to the
 959 attribute constructor.  (Trying to add an attribute that has no associated
 960 methods is almost always an error.)
 961
 962 =item B<< $attr->remove_accessors >>
 963
 964 This method overrides the parent to also remove delegation methods.
 965
 966 =item B<< $attr->install_delegation >>
 967
 968 This method adds its delegation methods to the attribute's associated
 969 class, if it has any to add.
 970
 971 =item B<< $attr->remove_delegation >>
 972
 973 This method remove its delegation methods from the attribute's
 974 associated class.
 975
 976 =item B<< $attr->accessor_metaclass >>
 977
 978 Returns the accessor metaclass name, which defaults to
 979 L<Moose::Meta::Method::Accessor>.
 980
 981 =item B<< $attr->delegation_metaclass >>
 982
 983 Returns the delegation metaclass name, which defaults to
 984 L<Moose::Meta::Method::Delegation>.
 985
 986 =back
 987
 988 =head2 Additional Moose features
 989
 990 These methods are not found in the superclass. They support features
 991 provided by Moose.
 992
 993 =over 4
 994
 995 =item B<< $attr->does($role) >>
 996
 997 This indicates whether the I<attribute itself> does the given
 998 role. The role can be given as a full class name, or as a resolvable
 999 trait name.
1000
1001 Note that this checks the attribute itself, not its type constraint,
1002 so it is checking the attribute's metaclass and any traits applied to
1003 the attribute.
1004
1005 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1006
1007 This is an alternate constructor that handles the C<metaclass> and
1008 C<traits> options.
1009
1010 Effectively, this method is a factory that finds or creates the
1011 appropriate class for the given C<metaclass> and/or C<traits>.
1012
1013 Once it has the appropriate class, it will call C<< $class->new($name,
1014 %options) >> on that class.
1015
1016 =item B<< $attr->clone_and_inherit_options(%options) >>
1017
1018 This method supports the C<has '+foo'> feature. It does various bits
1019 of processing on the supplied C<%options> before ultimately calling
1020 the C<clone> method.
1021
1022 One of its main tasks is to make sure that the C<%options> provided
1023 does not include the options returned by the
1024 C<illegal_options_for_inheritance> method.
1025
1026 =item B<< $attr->illegal_options_for_inheritance >>
1027
1028 This returns a blacklist of options that can not be overridden in a
1029 subclass's attribute definition.
1030
1031 This exists to allow a custom metaclass to change or add to the list
1032 of options which can not be changed.
1033
1034 =item B<< $attr->type_constraint >>
1035
1036 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1037 if it has one.
1038
1039 =item B<< $attr->has_type_constraint >>
1040
1041 Returns true if this attribute has a type constraint.
1042
1043 =item B<< $attr->verify_against_type_constraint($value) >>
1044
1045 Given a value, this method returns true if the value is valid for the
1046 attribute's type constraint. If the value is not valid, it throws an
1047 error.
1048
1049 =item B<< $attr->handles >>
1050
1051 This returns the value of the C<handles> option passed to the
1052 constructor.
1053
1054 =item B<< $attr->has_handles >>
1055
1056 Returns true if this attribute performs delegation.
1057
1058 =item B<< $attr->is_weak_ref >>
1059
1060 Returns true if this attribute stores its value as a weak reference.
1061
1062 =item B<< $attr->is_required >>
1063
1064 Returns true if this attribute is required to have a value.
1065
1066 =item B<< $attr->is_lazy >>
1067
1068 Returns true if this attribute is lazy.
1069
1070 =item B<< $attr->is_lazy_build >>
1071
1072 Returns true if the C<lazy_build> option was true when passed to the
1073 constructor.
1074
1075 =item B<< $attr->should_coerce >>
1076
1077 Returns true if the C<coerce> option passed to the constructor was
1078 true.
1079
1080 =item B<< $attr->should_auto_deref >>
1081
1082 Returns true if the C<auto_deref> option passed to the constructor was
1083 true.
1084
1085 =item B<< $attr->trigger >>
1086
1087 This is the subroutine reference that was in the C<trigger> option
1088 passed to the constructor, if any.
1089
1090 =item B<< $attr->has_trigger >>
1091
1092 Returns true if this attribute has a trigger set.
1093
1094 =item B<< $attr->documentation >>
1095
1096 Returns the value that was in the C<documentation> option passed to
1097 the constructor, if any.
1098
1099 =item B<< $attr->has_documentation >>
1100
1101 Returns true if this attribute has any documentation.
1102
1103 =item B<< $attr->applied_traits >>
1104
1105 This returns an array reference of all the traits which were applied
1106 to this attribute. If none were applied, this returns C<undef>.
1107
1108 =item B<< $attr->has_applied_traits >>
1109
1110 Returns true if this attribute has any traits applied.
1111
1112 =back
1113
1114 =head1 BUGS
1115
1116 See L<Moose/BUGS> for details on reporting bugs.
1117
1118 =head1 AUTHOR
1119
1120 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1121
1122 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1123
1124 =head1 COPYRIGHT AND LICENSE
1125
1126 Copyright 2006-2010 by Infinity Interactive, Inc.
1127
1128 L<http://www.iinteractive.com>
1129
1130 This library is free software; you can redistribute it and/or modify
1131 it under the same terms as Perl itself.
1132
1133 =cut