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