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