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