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.63';
  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 );
 149
 150 sub legal_options_for_inheritance { @legal_options_for_inheritance }
 151
 152 # NOTE/TODO
 153 # This method *must* be able to handle
 154 # Class::MOP::Attribute instances as
 155 # well. Yes, I know that is wrong, but
 156 # apparently we didn't realize it was
 157 # doing that and now we have some code
 158 # which is dependent on it. The real
 159 # solution of course is to push this
 160 # feature back up into Class::MOP::Attribute
 161 # but I not right now, I am too lazy.
 162 # However if you are reading this and
 163 # looking for something to do,.. please
 164 # be my guest.
 165 # - stevan
 166 sub clone_and_inherit_options {
 167     my ($self, %options) = @_;
 168
 169     my %copy = %options;
 170
 171     my %actual_options;
 172
 173     # NOTE:
 174     # we may want to extends a Class::MOP::Attribute
 175     # in which case we need to be able to use the
 176     # core set of legal options that have always
 177     # been here. But we allows Moose::Meta::Attribute
 178     # instances to changes them.
 179     # - SL
 180     my @legal_options = $self->can('legal_options_for_inheritance')
 181         ? $self->legal_options_for_inheritance
 182         : @legal_options_for_inheritance;
 183
 184     foreach my $legal_option (@legal_options) {
 185         if (exists $options{$legal_option}) {
 186             $actual_options{$legal_option} = $options{$legal_option};
 187             delete $options{$legal_option};
 188         }
 189     }
 190
 191     if ($options{isa}) {
 192         my $type_constraint;
 193         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
 194             $type_constraint = $options{isa};
 195         }
 196         else {
 197             $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
 198             (defined $type_constraint)
 199                 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
 200         }
 201
 202         $actual_options{type_constraint} = $type_constraint;
 203         delete $options{isa};
 204     }
 205
 206     if ($options{does}) {
 207         my $type_constraint;
 208         if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
 209             $type_constraint = $options{does};
 210         }
 211         else {
 212             $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
 213             (defined $type_constraint)
 214                 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
 215         }
 216
 217         $actual_options{type_constraint} = $type_constraint;
 218         delete $options{does};
 219     }
 220
 221     # NOTE:
 222     # this doesn't apply to Class::MOP::Attributes,
 223     # so we can ignore it for them.
 224     # - SL
 225     if ($self->can('interpolate_class')) {
 226         ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(%options);
 227
 228         my %seen;
 229         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
 230         $actual_options{traits} = \@all_traits if @all_traits;
 231
 232         delete @options{qw(metaclass traits)};
 233     }
 234
 235     (scalar keys %options == 0)
 236         || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options);
 237
 238
 239     $self->clone(%actual_options);
 240 }
 241
 242 sub clone {
 243     my ( $self, %params ) = @_;
 244
 245     my $class = $params{metaclass} || ref $self;
 246
 247     if ( 0 and $class eq ref $self ) {
 248         return $self->SUPER::clone(%params);
 249     } else {
 250         my ( @init, @non_init );
 251
 252         foreach my $attr ( grep { $_->has_value($self) } $self->meta->compute_all_applicable_attributes ) {
 253             push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
 254         }
 255
 256         my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
 257
 258         my $name = delete $new_params{name};
 259
 260         my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
 261
 262         foreach my $attr ( @non_init ) {
 263             $attr->set_value($clone, $attr->get_value($self));
 264         }
 265
 266
 267         return $clone;
 268     }
 269 }
 270
 271 sub _process_options {
 272     my ($class, $name, $options) = @_;
 273
 274     if (exists $options->{is}) {
 275
 276         ### -------------------------
 277         ## is => ro, writer => _foo    # turns into (reader => foo, writer => _foo) as before
 278         ## is => rw, writer => _foo    # turns into (reader => foo, writer => _foo)
 279         ## is => rw, accessor => _foo  # turns into (accessor => _foo)
 280         ## is => ro, accessor => _foo  # error, accesor is rw
 281         ### -------------------------
 282
 283         if ($options->{is} eq 'ro') {
 284             $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
 285                 if exists $options->{accessor};
 286             $options->{reader} ||= $name;
 287         }
 288         elsif ($options->{is} eq 'rw') {
 289             if ($options->{writer}) {
 290                 $options->{reader} ||= $name;
 291             }
 292             else {
 293                 $options->{accessor} ||= $name;
 294             }
 295         }
 296         else {
 297             $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
 298         }
 299     }
 300
 301     if (exists $options->{isa}) {
 302         if (exists $options->{does}) {
 303             if (eval { $options->{isa}->can('does') }) {
 304                 ($options->{isa}->does($options->{does}))
 305                     || $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);
 306             }
 307             else {
 308                 $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
 309             }
 310         }
 311
 312         # allow for anon-subtypes here ...
 313         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 314             $options->{type_constraint} = $options->{isa};
 315         }
 316         else {
 317             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
 318         }
 319     }
 320     elsif (exists $options->{does}) {
 321         # allow for anon-subtypes here ...
 322         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 323                 $options->{type_constraint} = $options->{does};
 324         }
 325         else {
 326             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
 327         }
 328     }
 329
 330     if (exists $options->{coerce} && $options->{coerce}) {
 331         (exists $options->{type_constraint})
 332             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options);
 333         $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options)
 334             if $options->{weak_ref};
 335     }
 336
 337     if (exists $options->{trigger}) {
 338         ('CODE' eq ref $options->{trigger})
 339             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
 340     }
 341
 342     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 343         (exists $options->{type_constraint})
 344             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options);
 345         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 346          $options->{type_constraint}->is_a_type_of('HashRef'))
 347             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options);
 348     }
 349
 350     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
 351         $class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options)
 352             if exists $options->{default};
 353         $options->{lazy}      = 1;
 354         $options->{required}  = 1;
 355         $options->{builder} ||= "_build_${name}";
 356         if ($name =~ /^_/) {
 357             $options->{clearer}   ||= "_clear${name}";
 358             $options->{predicate} ||= "_has${name}";
 359         }
 360         else {
 361             $options->{clearer}   ||= "clear_${name}";
 362             $options->{predicate} ||= "has_${name}";
 363         }
 364     }
 365
 366     if (exists $options->{lazy} && $options->{lazy}) {
 367         (exists $options->{default} || defined $options->{builder} )
 368             || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
 369     }
 370
 371     if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
 372         $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
 373     }
 374
 375 }
 376
 377 sub initialize_instance_slot {
 378     my ($self, $meta_instance, $instance, $params) = @_;
 379     my $init_arg = $self->init_arg();
 380     # try to fetch the init arg from the %params ...
 381
 382     my $val;
 383     my $value_is_set;
 384     if ( defined($init_arg) and exists $params->{$init_arg}) {
 385         $val = $params->{$init_arg};
 386         $value_is_set = 1;
 387     }
 388     else {
 389         # skip it if it's lazy
 390         return if $self->is_lazy;
 391         # and die if it's required and doesn't have a default value
 392         $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
 393             if $self->is_required && !$self->has_default && !$self->has_builder;
 394
 395         # if nothing was in the %params, we can use the
 396         # attribute's default value (if it has one)
 397         if ($self->has_default) {
 398             $val = $self->default($instance);
 399             $value_is_set = 1;
 400         }
 401         elsif ($self->has_builder) {
 402             $val = $self->_call_builder($instance);
 403             $value_is_set = 1;
 404         }
 405     }
 406
 407     return unless $value_is_set;
 408
 409     if ($self->has_type_constraint) {
 410         my $type_constraint = $self->type_constraint;
 411         if ($self->should_coerce && $type_constraint->has_coercion) {
 412             $val = $type_constraint->coerce($val);
 413         }
 414         $type_constraint->check($val)
 415             || $self->throw_error("Attribute ("
 416                      . $self->name
 417                      . ") does not pass the type constraint because: "
 418                      . $type_constraint->get_message($val), data => $val, object => $instance);
 419     }
 420
 421     $self->set_initial_value($instance, $val);
 422     $meta_instance->weaken_slot_value($instance, $self->name)
 423         if ref $val && $self->is_weak_ref;
 424 }
 425
 426 sub _call_builder {
 427     my ( $self, $instance ) = @_;
 428
 429     my $builder = $self->builder();
 430
 431     return $instance->$builder()
 432         if $instance->can( $self->builder );
 433
 434     $self->throw_error(  blessed($instance)
 435             . " does not support builder method '"
 436             . $self->builder
 437             . "' for attribute '"
 438             . $self->name
 439             . "'",
 440             object => $instance,
 441      );
 442 }
 443
 444 ## Slot management
 445
 446 # FIXME:
 447 # this duplicates too much code from
 448 # Class::MOP::Attribute, we need to
 449 # refactor these bits eventually.
 450 # - SL
 451 sub _set_initial_slot_value {
 452     my ($self, $meta_instance, $instance, $value) = @_;
 453
 454     my $slot_name = $self->name;
 455
 456     return $meta_instance->set_slot_value($instance, $slot_name, $value)
 457         unless $self->has_initializer;
 458
 459     my ($type_constraint, $can_coerce);
 460     if ($self->has_type_constraint) {
 461         $type_constraint = $self->type_constraint;
 462         $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
 463     }
 464
 465     my $callback = sub {
 466         my $val = shift;
 467         if ($type_constraint) {
 468             $val = $type_constraint->coerce($val)
 469                 if $can_coerce;
 470             $type_constraint->check($val)
 471                 || $self->throw_error("Attribute ("
 472                          . $slot_name
 473                          . ") does not pass the type constraint because: "
 474                          . $type_constraint->get_message($val), data => $val, object => $instance);
 475         }
 476         $meta_instance->set_slot_value($instance, $slot_name, $val);
 477     };
 478
 479     my $initializer = $self->initializer;
 480
 481     # most things will just want to set a value, so make it first arg
 482     $instance->$initializer($value, $callback, $self);
 483 }
 484
 485 sub set_value {
 486     my ($self, $instance, @args) = @_;
 487     my $value = $args[0];
 488
 489     my $attr_name = $self->name;
 490
 491     if ($self->is_required and not @args) {
 492         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
 493     }
 494
 495     if ($self->has_type_constraint) {
 496
 497         my $type_constraint = $self->type_constraint;
 498
 499         if ($self->should_coerce) {
 500             $value = $type_constraint->coerce($value);
 501         }
 502         $type_constraint->_compiled_type_constraint->($value)
 503             || $self->throw_error("Attribute ("
 504                      . $self->name
 505                      . ") does not pass the type constraint because "
 506                      . $type_constraint->get_message($value), object => $instance, data => $value);
 507     }
 508
 509     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 510                                          ->get_meta_instance;
 511
 512     $meta_instance->set_slot_value($instance, $attr_name, $value);
 513
 514     if (ref $value && $self->is_weak_ref) {
 515         $meta_instance->weaken_slot_value($instance, $attr_name);
 516     }
 517
 518     if ($self->has_trigger) {
 519         $self->trigger->($instance, $value, $self);
 520     }
 521 }
 522
 523 sub get_value {
 524     my ($self, $instance) = @_;
 525
 526     if ($self->is_lazy) {
 527         unless ($self->has_value($instance)) {
 528             my $value;
 529             if ($self->has_default) {
 530                 $value = $self->default($instance);
 531             } elsif ( $self->has_builder ) {
 532                 $value = $self->_call_builder($instance);
 533             }
 534             if ($self->has_type_constraint) {
 535                 my $type_constraint = $self->type_constraint;
 536                 $value = $type_constraint->coerce($value)
 537                     if ($self->should_coerce);
 538                 $type_constraint->check($value)
 539                   || $self->throw_error("Attribute (" . $self->name
 540                       . ") does not pass the type constraint because: "
 541                       . $type_constraint->get_message($value), type_constraint => $type_constraint, data => $value);
 542             }
 543             $self->set_initial_value($instance, $value);
 544         }
 545     }
 546
 547     if ($self->should_auto_deref) {
 548
 549         my $type_constraint = $self->type_constraint;
 550
 551         if ($type_constraint->is_a_type_of('ArrayRef')) {
 552             my $rv = $self->SUPER::get_value($instance);
 553             return unless defined $rv;
 554             return wantarray ? @{ $rv } : $rv;
 555         }
 556         elsif ($type_constraint->is_a_type_of('HashRef')) {
 557             my $rv = $self->SUPER::get_value($instance);
 558             return unless defined $rv;
 559             return wantarray ? %{ $rv } : $rv;
 560         }
 561         else {
 562             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
 563         }
 564
 565     }
 566     else {
 567
 568         return $self->SUPER::get_value($instance);
 569     }
 570 }
 571
 572 ## installing accessors
 573
 574 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 575
 576 sub install_accessors {
 577     my $self = shift;
 578     $self->SUPER::install_accessors(@_);
 579     $self->install_delegation if $self->has_handles;
 580     return;
 581 }
 582
 583 sub remove_accessors {
 584     my $self = shift;
 585     $self->SUPER::remove_accessors(@_);
 586     $self->remove_delegation if $self->has_handles;
 587     return;
 588 }
 589
 590 sub install_delegation {
 591     my $self = shift;
 592
 593     # NOTE:
 594     # Here we canonicalize the 'handles' option
 595     # this will sort out any details and always
 596     # return an hash of methods which we want
 597     # to delagate to, see that method for details
 598     my %handles = $self->_canonicalize_handles;
 599
 600
 601     # install the delegation ...
 602     my $associated_class = $self->associated_class;
 603     foreach my $handle (keys %handles) {
 604         my $method_to_call = $handles{$handle};
 605         my $class_name = $associated_class->name;
 606         my $name = "${class_name}::${handle}";
 607
 608             (!$associated_class->has_method($handle))
 609                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 610
 611         # NOTE:
 612         # handles is not allowed to delegate
 613         # any of these methods, as they will
 614         # override the ones in your class, which
 615         # is almost certainly not what you want.
 616
 617         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 618         #cluck("Not delegating method '$handle' because it is a core method") and
 619         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 620
 621         my $method = $self->_make_delegation_method($handle, $method_to_call);
 622
 623         $self->associated_class->add_method($method->name, $method);
 624     }
 625 }
 626
 627 sub remove_delegation {
 628     my $self = shift;
 629     my %handles = $self->_canonicalize_handles;
 630     my $associated_class = $self->associated_class;
 631     foreach my $handle (keys %handles) {
 632         $self->associated_class->remove_method($handle);
 633     }
 634 }
 635
 636 # private methods to help delegation ...
 637
 638 sub _canonicalize_handles {
 639     my $self    = shift;
 640     my $handles = $self->handles;
 641     if (my $handle_type = ref($handles)) {
 642         if ($handle_type eq 'HASH') {
 643             return %{$handles};
 644         }
 645         elsif ($handle_type eq 'ARRAY') {
 646             return map { $_ => $_ } @{$handles};
 647         }
 648         elsif ($handle_type eq 'Regexp') {
 649             ($self->has_type_constraint)
 650                 || $self->throw_error("Cannot delegate methods based on a RegExpr without a type constraint (isa)", data => $handles);
 651             return map  { ($_ => $_) }
 652                    grep { /$handles/ } $self->_get_delegate_method_list;
 653         }
 654         elsif ($handle_type eq 'CODE') {
 655             return $handles->($self, $self->_find_delegate_metaclass);
 656         }
 657         else {
 658             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 659         }
 660     }
 661     else {
 662         Class::MOP::load_class($handles)
 663             unless Class::MOP::is_class_loaded($handles);
 664
 665         my $role_meta = eval { $handles->meta };
 666         if ($@) {
 667             $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@);
 668         }
 669
 670         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 671             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles);
 672
 673         return map { $_ => $_ } (
 674             $role_meta->get_method_list,
 675             $role_meta->get_required_method_list
 676         );
 677     }
 678 }
 679
 680 sub _find_delegate_metaclass {
 681     my $self = shift;
 682     if (my $class = $self->_isa_metadata) {
 683         # if the class does have
 684         # a meta method, use it
 685         return $class->meta if $class->can('meta');
 686         # otherwise we might be
 687         # dealing with a non-Moose
 688         # class, and need to make
 689         # our own metaclass
 690         return Moose::Meta::Class->initialize($class);
 691     }
 692     elsif (my $role = $self->_does_metadata) {
 693         # our role will always have
 694         # a meta method
 695         return $role->meta;
 696     }
 697     else {
 698         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 699     }
 700 }
 701
 702 sub _get_delegate_method_list {
 703     my $self = shift;
 704     my $meta = $self->_find_delegate_metaclass;
 705     if ($meta->isa('Class::MOP::Class')) {
 706         return map  { $_->name }  # NOTE: !never! delegate &meta
 707                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 708                     $meta->get_all_methods;
 709     }
 710     elsif ($meta->isa('Moose::Meta::Role')) {
 711         return $meta->get_method_list;
 712     }
 713     else {
 714         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 715     }
 716 }
 717
 718 sub _make_delegation_method {
 719     my ( $self, $handle_name, $method_to_call ) = @_;
 720
 721     my $method_body;
 722
 723     $method_body = $method_to_call
 724         if 'CODE' eq ref($method_to_call);
 725
 726     return Moose::Meta::Method::Delegation->new(
 727         name               => $handle_name,
 728         package_name       => $self->associated_class->name,
 729         attribute          => $self,
 730         delegate_to_method => $method_to_call,
 731     );
 732 }
 733
 734 package Moose::Meta::Attribute::Custom::Moose;
 735 sub register_implementation { 'Moose::Meta::Attribute' }
 736
 737 1;
 738
 739 __END__
 740
 741 =pod
 742
 743 =head1 NAME
 744
 745 Moose::Meta::Attribute - The Moose attribute metaclass
 746
 747 =head1 DESCRIPTION
 748
 749 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 750 extensions.
 751
 752 For the most part, the only time you will ever encounter an
 753 instance of this class is if you are doing some serious deep
 754 introspection. To really understand this class, you need to refer
 755 to the L<Class::MOP::Attribute> documentation.
 756
 757 =head1 METHODS
 758
 759 =head2 Overridden methods
 760
 761 These methods override methods in L<Class::MOP::Attribute> and add
 762 Moose specific features. You can safely assume though that they
 763 will behave just as L<Class::MOP::Attribute> does.
 764
 765 =over 4
 766
 767 =item B<new>
 768
 769 =item B<clone>
 770
 771 =item B<does>
 772
 773 =item B<initialize_instance_slot>
 774
 775 =item B<install_accessors>
 776
 777 =item B<remove_accessors>
 778
 779 =item B<install_delegation>
 780
 781 =item B<remove_delegation>
 782
 783 =item B<accessor_metaclass>
 784
 785 =item B<get_value>
 786
 787 =item B<set_value>
 788
 789   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 790   if($@) {
 791     print "Oops: $@\n";
 792   }
 793
 794 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 795
 796 Before setting the value, a check is made on the type constraint of
 797 the attribute, if it has one, to see if the value passes it. If the
 798 value fails to pass, the set operation dies with a L<throw_error>.
 799
 800 Any coercion to convert values is done before checking the type constraint.
 801
 802 To check a value against a type constraint before setting it, fetch the
 803 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 804 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 805 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 806 for an example.
 807
 808 =back
 809
 810 =head2 Additional Moose features
 811
 812 Moose attributes support type-constraint checking, weak reference
 813 creation and type coercion.
 814
 815 =over 4
 816
 817 =item B<throw_error>
 818
 819 Delegates to C<associated_class> or C<Moose::Meta::Class> if there is none.
 820
 821 =item B<interpolate_class_and_new>
 822
 823 =item B<interpolate_class>
 824
 825 When called as a class method causes interpretation of the C<metaclass> and
 826 C<traits> options.
 827
 828 =item B<clone_and_inherit_options>
 829
 830 This is to support the C<has '+foo'> feature, it clones an attribute
 831 from a superclass and allows a very specific set of changes to be made
 832 to the attribute.
 833
 834 =item B<legal_options_for_inheritance>
 835
 836 Whitelist with options you can change. You can overload it in your custom
 837 metaclass to allow your options be inheritable.
 838
 839 =item B<has_type_constraint>
 840
 841 Returns true if this meta-attribute has a type constraint.
 842
 843 =item B<type_constraint>
 844
 845 A read-only accessor for this meta-attribute's type constraint. For
 846 more information on what you can do with this, see the documentation
 847 for L<Moose::Meta::TypeConstraint>.
 848
 849 =item B<has_handles>
 850
 851 Returns true if this meta-attribute performs delegation.
 852
 853 =item B<handles>
 854
 855 This returns the value which was passed into the handles option.
 856
 857 =item B<is_weak_ref>
 858
 859 Returns true if this meta-attribute produces a weak reference.
 860
 861 =item B<is_required>
 862
 863 Returns true if this meta-attribute is required to have a value.
 864
 865 =item B<is_lazy>
 866
 867 Returns true if this meta-attribute should be initialized lazily.
 868
 869 NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
 870
 871 =item B<is_lazy_build>
 872
 873 Returns true if this meta-attribute should be initialized lazily through
 874 the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
 875 make your attribute required and lazy. In addition it will set the builder, clearer
 876 and predicate options for you using the following convention.
 877
 878    #If your attribute name starts with an underscore:
 879    has '_foo' => (lazy_build => 1);
 880    #is the same as
 881    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo');
 882    # or
 883    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
 884
 885    #If your attribute name does not start with an underscore:
 886    has 'foo' => (lazy_build => 1);
 887    #is the same as
 888    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo');
 889    # or
 890    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
 891
 892 The reason for the different naming of the C<builder> is that the C<builder>
 893 method is a private method while the C<clearer> and C<predicate> methods
 894 are public methods.
 895
 896 NOTE: This means your class should provide a method whose name matches the value
 897 of the builder part, in this case _build__foo or _build_foo.
 898
 899 =item B<should_coerce>
 900
 901 Returns true if this meta-attribute should perform type coercion.
 902
 903 =item B<should_auto_deref>
 904
 905 Returns true if this meta-attribute should perform automatic
 906 auto-dereferencing.
 907
 908 NOTE: This can only be done for attributes whose type constraint is
 909 either I<ArrayRef> or I<HashRef>.
 910
 911 =item B<has_trigger>
 912
 913 Returns true if this meta-attribute has a trigger set.
 914
 915 =item B<trigger>
 916
 917 This is a CODE reference which will be executed every time the
 918 value of an attribute is assigned. The CODE ref will get two values,
 919 the invocant and the new value. This can be used to handle I<basic>
 920 bi-directional relations.
 921
 922 =item B<documentation>
 923
 924 This is a string which contains the documentation for this attribute.
 925 It serves no direct purpose right now, but it might in the future
 926 in some kind of automated documentation system perhaps.
 927
 928 =item B<has_documentation>
 929
 930 Returns true if this meta-attribute has any documentation.
 931
 932 =item B<applied_traits>
 933
 934 This will return the ARRAY ref of all the traits applied to this
 935 attribute, or if no traits have been applied, it returns C<undef>.
 936
 937 =item B<has_applied_traits>
 938
 939 Returns true if this meta-attribute has any traits applied.
 940
 941 =back
 942
 943 =head1 BUGS
 944
 945 All complex software has bugs lurking in it, and this module is no
 946 exception. If you find a bug please either email me, or add the bug
 947 to cpan-RT.
 948
 949 =head1 AUTHOR
 950
 951 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 952
 953 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 954
 955 =head1 COPYRIGHT AND LICENSE
 956
 957 Copyright 2006-2008 by Infinity Interactive, Inc.
 958
 959 L<http://www.iinteractive.com>
 960
 961 This library is free software; you can redistribute it and/or modify
 962 it under the same terms as Perl itself.
 963
 964 =cut