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