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