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