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.72';
  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) } $self->meta->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     if ($self->has_type_constraint) {
 407         my $type_constraint = $self->type_constraint;
 408         if ($self->should_coerce && $type_constraint->has_coercion) {
 409             $val = $type_constraint->coerce($val);
 410         }
 411         $self->verify_against_type_constraint($val, instance => $instance);
 412     }
 413
 414     $self->set_initial_value($instance, $val);
 415     $meta_instance->weaken_slot_value($instance, $self->name)
 416         if ref $val && $self->is_weak_ref;
 417 }
 418
 419 sub _call_builder {
 420     my ( $self, $instance ) = @_;
 421
 422     my $builder = $self->builder();
 423
 424     return $instance->$builder()
 425         if $instance->can( $self->builder );
 426
 427     $self->throw_error(  blessed($instance)
 428             . " does not support builder method '"
 429             . $self->builder
 430             . "' for attribute '"
 431             . $self->name
 432             . "'",
 433             object => $instance,
 434      );
 435 }
 436
 437 ## Slot management
 438
 439 # FIXME:
 440 # this duplicates too much code from
 441 # Class::MOP::Attribute, we need to
 442 # refactor these bits eventually.
 443 # - SL
 444 sub _set_initial_slot_value {
 445     my ($self, $meta_instance, $instance, $value) = @_;
 446
 447     my $slot_name = $self->name;
 448
 449     return $meta_instance->set_slot_value($instance, $slot_name, $value)
 450         unless $self->has_initializer;
 451
 452     my ($type_constraint, $can_coerce);
 453     if ($self->has_type_constraint) {
 454         $type_constraint = $self->type_constraint;
 455         $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
 456     }
 457
 458     my $callback = sub {
 459         my $val = shift;
 460         if ($type_constraint) {
 461             $val = $type_constraint->coerce($val)
 462                 if $can_coerce;
 463             $self->verify_against_type_constraint($val, object => $instance);
 464         }
 465         $meta_instance->set_slot_value($instance, $slot_name, $val);
 466     };
 467
 468     my $initializer = $self->initializer;
 469
 470     # most things will just want to set a value, so make it first arg
 471     $instance->$initializer($value, $callback, $self);
 472 }
 473
 474 sub set_value {
 475     my ($self, $instance, @args) = @_;
 476     my $value = $args[0];
 477
 478     my $attr_name = $self->name;
 479
 480     if ($self->is_required and not @args) {
 481         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
 482     }
 483
 484     if ($self->has_type_constraint) {
 485
 486         my $type_constraint = $self->type_constraint;
 487
 488         if ($self->should_coerce) {
 489             $value = $type_constraint->coerce($value);
 490         }
 491         $type_constraint->_compiled_type_constraint->($value)
 492             || $self->throw_error("Attribute ("
 493                      . $self->name
 494                      . ") does not pass the type constraint because "
 495                      . $type_constraint->get_message($value), object => $instance, data => $value);
 496     }
 497
 498     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 499                                          ->get_meta_instance;
 500
 501     $meta_instance->set_slot_value($instance, $attr_name, $value);
 502
 503     if (ref $value && $self->is_weak_ref) {
 504         $meta_instance->weaken_slot_value($instance, $attr_name);
 505     }
 506
 507     if ($self->has_trigger) {
 508         $self->trigger->($instance, $value);
 509     }
 510 }
 511
 512 sub get_value {
 513     my ($self, $instance) = @_;
 514
 515     if ($self->is_lazy) {
 516         unless ($self->has_value($instance)) {
 517             my $value;
 518             if ($self->has_default) {
 519                 $value = $self->default($instance);
 520             } elsif ( $self->has_builder ) {
 521                 $value = $self->_call_builder($instance);
 522             }
 523             if ($self->has_type_constraint) {
 524                 my $type_constraint = $self->type_constraint;
 525                 $value = $type_constraint->coerce($value)
 526                     if ($self->should_coerce);
 527                 $self->verify_against_type_constraint($value);
 528             }
 529             $self->set_initial_value($instance, $value);
 530         }
 531     }
 532
 533     if ($self->should_auto_deref) {
 534
 535         my $type_constraint = $self->type_constraint;
 536
 537         if ($type_constraint->is_a_type_of('ArrayRef')) {
 538             my $rv = $self->SUPER::get_value($instance);
 539             return unless defined $rv;
 540             return wantarray ? @{ $rv } : $rv;
 541         }
 542         elsif ($type_constraint->is_a_type_of('HashRef')) {
 543             my $rv = $self->SUPER::get_value($instance);
 544             return unless defined $rv;
 545             return wantarray ? %{ $rv } : $rv;
 546         }
 547         else {
 548             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
 549         }
 550
 551     }
 552     else {
 553
 554         return $self->SUPER::get_value($instance);
 555     }
 556 }
 557
 558 ## installing accessors
 559
 560 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 561
 562 sub install_accessors {
 563     my $self = shift;
 564     $self->SUPER::install_accessors(@_);
 565     $self->install_delegation if $self->has_handles;
 566     return;
 567 }
 568
 569 sub remove_accessors {
 570     my $self = shift;
 571     $self->SUPER::remove_accessors(@_);
 572     $self->remove_delegation if $self->has_handles;
 573     return;
 574 }
 575
 576 sub install_delegation {
 577     my $self = shift;
 578
 579     # NOTE:
 580     # Here we canonicalize the 'handles' option
 581     # this will sort out any details and always
 582     # return an hash of methods which we want
 583     # to delagate to, see that method for details
 584     my %handles = $self->_canonicalize_handles;
 585
 586
 587     # install the delegation ...
 588     my $associated_class = $self->associated_class;
 589     foreach my $handle (keys %handles) {
 590         my $method_to_call = $handles{$handle};
 591         my $class_name = $associated_class->name;
 592         my $name = "${class_name}::${handle}";
 593
 594             (!$associated_class->has_method($handle))
 595                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 596
 597         # NOTE:
 598         # handles is not allowed to delegate
 599         # any of these methods, as they will
 600         # override the ones in your class, which
 601         # is almost certainly not what you want.
 602
 603         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 604         #cluck("Not delegating method '$handle' because it is a core method") and
 605         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 606
 607         my $method = $self->_make_delegation_method($handle, $method_to_call);
 608
 609         $self->associated_class->add_method($method->name, $method);
 610     }
 611 }
 612
 613 sub remove_delegation {
 614     my $self = shift;
 615     my %handles = $self->_canonicalize_handles;
 616     my $associated_class = $self->associated_class;
 617     foreach my $handle (keys %handles) {
 618         $self->associated_class->remove_method($handle);
 619     }
 620 }
 621
 622 # private methods to help delegation ...
 623
 624 sub _canonicalize_handles {
 625     my $self    = shift;
 626     my $handles = $self->handles;
 627     if (my $handle_type = ref($handles)) {
 628         if ($handle_type eq 'HASH') {
 629             return %{$handles};
 630         }
 631         elsif ($handle_type eq 'ARRAY') {
 632             return map { $_ => $_ } @{$handles};
 633         }
 634         elsif ($handle_type eq 'Regexp') {
 635             ($self->has_type_constraint)
 636                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 637             return map  { ($_ => $_) }
 638                    grep { /$handles/ } $self->_get_delegate_method_list;
 639         }
 640         elsif ($handle_type eq 'CODE') {
 641             return $handles->($self, $self->_find_delegate_metaclass);
 642         }
 643         else {
 644             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 645         }
 646     }
 647     else {
 648         Class::MOP::load_class($handles)
 649             unless Class::MOP::is_class_loaded($handles);
 650
 651         my $role_meta = eval { $handles->meta };
 652         if ($@) {
 653             $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@);
 654         }
 655
 656         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 657             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles);
 658
 659         return map { $_ => $_ } (
 660             $role_meta->get_method_list,
 661             $role_meta->get_required_method_list
 662         );
 663     }
 664 }
 665
 666 sub _find_delegate_metaclass {
 667     my $self = shift;
 668     if (my $class = $self->_isa_metadata) {
 669         # if the class does have
 670         # a meta method, use it
 671         return $class->meta if $class->can('meta');
 672         # otherwise we might be
 673         # dealing with a non-Moose
 674         # class, and need to make
 675         # our own metaclass
 676         return Moose::Meta::Class->initialize($class);
 677     }
 678     elsif (my $role = $self->_does_metadata) {
 679         # our role will always have
 680         # a meta method
 681         return $role->meta;
 682     }
 683     else {
 684         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 685     }
 686 }
 687
 688 sub _get_delegate_method_list {
 689     my $self = shift;
 690     my $meta = $self->_find_delegate_metaclass;
 691     if ($meta->isa('Class::MOP::Class')) {
 692         return map  { $_->name }  # NOTE: !never! delegate &meta
 693                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 694                     $meta->get_all_methods;
 695     }
 696     elsif ($meta->isa('Moose::Meta::Role')) {
 697         return $meta->get_method_list;
 698     }
 699     else {
 700         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 701     }
 702 }
 703
 704 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 705
 706 sub _make_delegation_method {
 707     my ( $self, $handle_name, $method_to_call ) = @_;
 708
 709     my $method_body;
 710
 711     $method_body = $method_to_call
 712         if 'CODE' eq ref($method_to_call);
 713
 714     return $self->delegation_metaclass->new(
 715         name               => $handle_name,
 716         package_name       => $self->associated_class->name,
 717         attribute          => $self,
 718         delegate_to_method => $method_to_call,
 719     );
 720 }
 721
 722 sub verify_against_type_constraint {
 723     my $self = shift;
 724     my $val  = shift;
 725
 726     return 1 if !$self->has_type_constraint;
 727
 728     my $type_constraint = $self->type_constraint;
 729
 730     $type_constraint->check($val)
 731         || $self->throw_error("Attribute ("
 732                  . $self->name
 733                  . ") does not pass the type constraint because: "
 734                  . $type_constraint->get_message($val), data => $val, @_);
 735 }
 736
 737 package Moose::Meta::Attribute::Custom::Moose;
 738 sub register_implementation { 'Moose::Meta::Attribute' }
 739
 740 1;
 741
 742 __END__
 743
 744 =pod
 745
 746 =head1 NAME
 747
 748 Moose::Meta::Attribute - The Moose attribute metaclass
 749
 750 =head1 DESCRIPTION
 751
 752 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 753 extensions.
 754
 755 For the most part, the only time you will ever encounter an
 756 instance of this class is if you are doing some serious deep
 757 introspection. To really understand this class, you need to refer
 758 to the L<Class::MOP::Attribute> documentation.
 759
 760 =head1 METHODS
 761
 762 =head2 Overridden methods
 763
 764 These methods override methods in L<Class::MOP::Attribute> and add
 765 Moose specific features. You can safely assume though that they
 766 will behave just as L<Class::MOP::Attribute> does.
 767
 768 =over 4
 769
 770 =item B<new>
 771
 772 =item B<clone>
 773
 774 =item B<does>
 775
 776 =item B<initialize_instance_slot>
 777
 778 =item B<install_accessors>
 779
 780 =item B<remove_accessors>
 781
 782 =item B<install_delegation>
 783
 784 =item B<remove_delegation>
 785
 786 =item B<accessor_metaclass>
 787
 788 =item B<delegation_metaclass>
 789
 790 =item B<get_value>
 791
 792 =item B<set_value>
 793
 794   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 795   if($@) {
 796     print "Oops: $@\n";
 797   }
 798
 799 I<Attribute (x) does not pass the type constraint (Int) with 'forty-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-2009 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