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