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