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