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             if (my $builder = $instance->can($self->builder)){
 380                 $val = $instance->$builder;
 381                 $value_is_set = 1;
 382             }
 383             else {
 384                 confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
 385             }
 386         }
 387     }
 388
 389     return unless $value_is_set;
 390
 391     if ($self->has_type_constraint) {
 392         my $type_constraint = $self->type_constraint;
 393         if ($self->should_coerce && $type_constraint->has_coercion) {
 394             $val = $type_constraint->coerce($val);
 395         }
 396         $type_constraint->check($val)
 397             || confess "Attribute ("
 398                      . $self->name
 399                      . ") does not pass the type constraint because: "
 400                      . $type_constraint->get_message($val);
 401     }
 402
 403     $self->set_initial_value($instance, $val);
 404     $meta_instance->weaken_slot_value($instance, $self->name)
 405         if ref $val && $self->is_weak_ref;
 406 }
 407
 408 ## Slot management
 409
 410 # FIXME:
 411 # this duplicates too much code from
 412 # Class::MOP::Attribute, we need to
 413 # refactor these bits eventually.
 414 # - SL
 415 sub _set_initial_slot_value {
 416     my ($self, $meta_instance, $instance, $value) = @_;
 417
 418     my $slot_name = $self->name;
 419
 420     return $meta_instance->set_slot_value($instance, $slot_name, $value)
 421         unless $self->has_initializer;
 422
 423     my ($type_constraint, $can_coerce);
 424     if ($self->has_type_constraint) {
 425         $type_constraint = $self->type_constraint;
 426         $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
 427     }
 428
 429     my $callback = sub {
 430         my $val = shift;
 431         if ($type_constraint) {
 432             $val = $type_constraint->coerce($val)
 433                 if $can_coerce;
 434             $type_constraint->check($val)
 435                 || confess "Attribute ("
 436                          . $slot_name
 437                          . ") does not pass the type constraint because: "
 438                          . $type_constraint->get_message($val);
 439         }
 440         $meta_instance->set_slot_value($instance, $slot_name, $val);
 441     };
 442
 443     my $initializer = $self->initializer;
 444
 445     # most things will just want to set a value, so make it first arg
 446     $instance->$initializer($value, $callback, $self);
 447 }
 448
 449 sub set_value {
 450     my ($self, $instance, @args) = @_;
 451     my $value = $args[0];
 452
 453     my $attr_name = $self->name;
 454
 455     if ($self->is_required and not @args) {
 456         confess "Attribute ($attr_name) is required";
 457     }
 458
 459     if ($self->has_type_constraint) {
 460
 461         my $type_constraint = $self->type_constraint;
 462
 463         if ($self->should_coerce) {
 464             $value = $type_constraint->coerce($value);
 465         }
 466         $type_constraint->_compiled_type_constraint->($value)
 467             || confess "Attribute ("
 468                      . $self->name
 469                      . ") does not pass the type constraint because "
 470                      . $type_constraint->get_message($value);
 471     }
 472
 473     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 474                                          ->get_meta_instance;
 475
 476     $meta_instance->set_slot_value($instance, $attr_name, $value);
 477
 478     if (ref $value && $self->is_weak_ref) {
 479         $meta_instance->weaken_slot_value($instance, $attr_name);
 480     }
 481
 482     if ($self->has_trigger) {
 483         $self->trigger->($instance, $value, $self);
 484     }
 485 }
 486
 487 sub get_value {
 488     my ($self, $instance) = @_;
 489
 490     if ($self->is_lazy) {
 491         unless ($self->has_value($instance)) {
 492             my $value;
 493             if ($self->has_default) {
 494                 $value = $self->default($instance);
 495             } elsif ( $self->has_builder ) {
 496                 if (my $builder = $instance->can($self->builder)){
 497                     $value = $instance->$builder;
 498                 }
 499                 else {
 500                     confess(blessed($instance)
 501                           . " does not support builder method '"
 502                           . $self->builder
 503                           . "' for attribute '"
 504                           . $self->name
 505                           . "'");
 506                 }
 507             }
 508             if ($self->has_type_constraint) {
 509                 my $type_constraint = $self->type_constraint;
 510                 $value = $type_constraint->coerce($value)
 511                     if ($self->should_coerce);
 512                 $type_constraint->check($value)
 513                   || confess "Attribute (" . $self->name
 514                       . ") does not pass the type constraint because: "
 515                       . $type_constraint->get_message($value);
 516             }
 517             $self->set_initial_value($instance, $value);
 518         }
 519     }
 520
 521     if ($self->should_auto_deref) {
 522
 523         my $type_constraint = $self->type_constraint;
 524
 525         if ($type_constraint->is_a_type_of('ArrayRef')) {
 526             my $rv = $self->SUPER::get_value($instance);
 527             return unless defined $rv;
 528             return wantarray ? @{ $rv } : $rv;
 529         }
 530         elsif ($type_constraint->is_a_type_of('HashRef')) {
 531             my $rv = $self->SUPER::get_value($instance);
 532             return unless defined $rv;
 533             return wantarray ? %{ $rv } : $rv;
 534         }
 535         else {
 536             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 537         }
 538
 539     }
 540     else {
 541
 542         return $self->SUPER::get_value($instance);
 543     }
 544 }
 545
 546 ## installing accessors
 547
 548 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 549
 550 sub install_accessors {
 551     my $self = shift;
 552     $self->SUPER::install_accessors(@_);
 553     $self->install_delegation if $self->has_handles;
 554     return;
 555 }
 556
 557 sub install_delegation {
 558     my $self = shift;
 559
 560     # NOTE:
 561     # Here we canonicalize the 'handles' option
 562     # this will sort out any details and always
 563     # return an hash of methods which we want
 564     # to delagate to, see that method for details
 565     my %handles = $self->_canonicalize_handles;
 566
 567     # find the accessor method for this attribute
 568     my $accessor = $self->_get_delegate_accessor;
 569
 570     # install the delegation ...
 571     my $associated_class = $self->associated_class;
 572     foreach my $handle (keys %handles) {
 573         my $method_to_call = $handles{$handle};
 574         my $class_name = $associated_class->name;
 575         my $name = "${class_name}::${handle}";
 576
 577         (!$associated_class->has_method($handle))
 578             || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 579
 580         # NOTE:
 581         # handles is not allowed to delegate
 582         # any of these methods, as they will
 583         # override the ones in your class, which
 584         # is almost certainly not what you want.
 585
 586         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 587         #cluck("Not delegating method '$handle' because it is a core method") and
 588         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 589
 590         if ('CODE' eq ref($method_to_call)) {
 591             $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
 592         }
 593         else {
 594             # NOTE:
 595             # we used to do a goto here, but the
 596             # goto didn't handle failure correctly
 597             # (it just returned nothing), so I took
 598             # that out. However, the more I thought
 599             # about it, the less I liked it doing
 600             # the goto, and I prefered the act of
 601             # delegation being actually represented
 602             # in the stack trace.
 603             # - SL
 604             $associated_class->add_method($handle => Class::MOP::subname($name, sub {
 605                 my $proxy = (shift)->$accessor();
 606                 (defined $proxy)
 607                     || confess "Cannot delegate $handle to $method_to_call because " .
 608                                "the value of " . $self->name . " is not defined";
 609                 $proxy->$method_to_call(@_);
 610             }));
 611         }
 612     }
 613 }
 614
 615 # private methods to help delegation ...
 616
 617 sub _get_delegate_accessor {
 618     my $self = shift;
 619     # find the accessor method for this attribute
 620     my $accessor = $self->get_read_method_ref;
 621     # then unpack it if we need too ...
 622     $accessor = $accessor->body if blessed $accessor;
 623     # return the accessor
 624     return $accessor;
 625 }
 626
 627 sub _canonicalize_handles {
 628     my $self    = shift;
 629     my $handles = $self->handles;
 630     if (my $handle_type = ref($handles)) {
 631         if ($handle_type eq 'HASH') {
 632             return %{$handles};
 633         }
 634         elsif ($handle_type eq 'ARRAY') {
 635             return map { $_ => $_ } @{$handles};
 636         }
 637         elsif ($handle_type eq 'Regexp') {
 638             ($self->has_type_constraint)
 639                 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 640             return map  { ($_ => $_) }
 641                    grep { /$handles/ } $self->_get_delegate_method_list;
 642         }
 643         elsif ($handle_type eq 'CODE') {
 644             return $handles->($self, $self->_find_delegate_metaclass);
 645         }
 646         else {
 647             confess "Unable to canonicalize the 'handles' option with $handles";
 648         }
 649     }
 650     else {
 651         my $role_meta = eval { $handles->meta };
 652         if ($@) {
 653             confess "Unable to canonicalize the 'handles' option with $handles because : $@";
 654         }
 655
 656         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 657             || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
 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         confess "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         confess "Unable to recognize the delegate metaclass '$meta'";
 701     }
 702 }
 703
 704 package Moose::Meta::Attribute::Custom::Moose;
 705 sub register_implementation { 'Moose::Meta::Attribute' }
 706
 707 1;
 708
 709 __END__
 710
 711 =pod
 712
 713 =head1 NAME
 714
 715 Moose::Meta::Attribute - The Moose attribute metaclass
 716
 717 =head1 DESCRIPTION
 718
 719 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 720 extensions.
 721
 722 For the most part, the only time you will ever encounter an
 723 instance of this class is if you are doing some serious deep
 724 introspection. To really understand this class, you need to refer
 725 to the L<Class::MOP::Attribute> documentation.
 726
 727 =head1 METHODS
 728
 729 =head2 Overridden methods
 730
 731 These methods override methods in L<Class::MOP::Attribute> and add
 732 Moose specific features. You can safely assume though that they
 733 will behave just as L<Class::MOP::Attribute> does.
 734
 735 =over 4
 736
 737 =item B<new>
 738
 739 =item B<clone>
 740
 741 =item B<does>
 742
 743 =item B<initialize_instance_slot>
 744
 745 =item B<install_accessors>
 746
 747 =item B<install_delegation>
 748
 749 =item B<accessor_metaclass>
 750
 751 =item B<get_value>
 752
 753 =item B<set_value>
 754
 755   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 756   if($@) {
 757     print "Oops: $@\n";
 758   }
 759
 760 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 761
 762 Before setting the value, a check is made on the type constraint of
 763 the attribute, if it has one, to see if the value passes it. If the
 764 value fails to pass, the set operation dies with a L<Carp/confess>.
 765
 766 Any coercion to convert values is done before checking the type constraint.
 767
 768 To check a value against a type constraint before setting it, fetch the
 769 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 770 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 771 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 772 for an example.
 773
 774 =back
 775
 776 =head2 Additional Moose features
 777
 778 Moose attributes support type-constraint checking, weak reference
 779 creation and type coercion.
 780
 781 =over 4
 782
 783 =item B<interpolate_class_and_new>
 784
 785 =item B<interpolate_class>
 786
 787 When called as a class method causes interpretation of the C<metaclass> and
 788 C<traits> options.
 789
 790 =item B<clone_and_inherit_options>
 791
 792 This is to support the C<has '+foo'> feature, it clones an attribute
 793 from a superclass and allows a very specific set of changes to be made
 794 to the attribute.
 795
 796 =item B<legal_options_for_inheritance>
 797
 798 Whitelist with options you can change. You can overload it in your custom
 799 metaclass to allow your options be inheritable.
 800
 801 =item B<has_type_constraint>
 802
 803 Returns true if this meta-attribute has a type constraint.
 804
 805 =item B<type_constraint>
 806
 807 A read-only accessor for this meta-attribute's type constraint. For
 808 more information on what you can do with this, see the documentation
 809 for L<Moose::Meta::TypeConstraint>.
 810
 811 =item B<has_handles>
 812
 813 Returns true if this meta-attribute performs delegation.
 814
 815 =item B<handles>
 816
 817 This returns the value which was passed into the handles option.
 818
 819 =item B<is_weak_ref>
 820
 821 Returns true if this meta-attribute produces a weak reference.
 822
 823 =item B<is_required>
 824
 825 Returns true if this meta-attribute is required to have a value.
 826
 827 =item B<is_lazy>
 828
 829 Returns true if this meta-attribute should be initialized lazily.
 830
 831 NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
 832
 833 =item B<is_lazy_build>
 834
 835 Returns true if this meta-attribute should be initialized lazily through
 836 the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
 837 make your attribute required and lazy. In addition it will set the builder, clearer
 838 and predicate options for you using the following convention.
 839
 840    #If your attribute name starts with an underscore:
 841    has '_foo' => (lazy_build => 1);
 842    #is the same as
 843    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo');
 844    # or
 845    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
 846
 847    #If your attribute name does not start with an underscore:
 848    has 'foo' => (lazy_build => 1);
 849    #is the same as
 850    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo');
 851    # or
 852    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
 853
 854 The reason for the different naming of the C<builder> is that the C<builder>
 855 method is a private method while the C<clearer> and C<predicate> methods
 856 are public methods.
 857
 858 NOTE: This means your class should provide a method whose name matches the value
 859 of the builder part, in this case _build__foo or _build_foo.
 860
 861 =item B<should_coerce>
 862
 863 Returns true if this meta-attribute should perform type coercion.
 864
 865 =item B<should_auto_deref>
 866
 867 Returns true if this meta-attribute should perform automatic
 868 auto-dereferencing.
 869
 870 NOTE: This can only be done for attributes whose type constraint is
 871 either I<ArrayRef> or I<HashRef>.
 872
 873 =item B<has_trigger>
 874
 875 Returns true if this meta-attribute has a trigger set.
 876
 877 =item B<trigger>
 878
 879 This is a CODE reference which will be executed every time the
 880 value of an attribute is assigned. The CODE ref will get two values,
 881 the invocant and the new value. This can be used to handle I<basic>
 882 bi-directional relations.
 883
 884 =item B<documentation>
 885
 886 This is a string which contains the documentation for this attribute.
 887 It serves no direct purpose right now, but it might in the future
 888 in some kind of automated documentation system perhaps.
 889
 890 =item B<has_documentation>
 891
 892 Returns true if this meta-attribute has any documentation.
 893
 894 =item B<applied_traits>
 895
 896 This will return the ARRAY ref of all the traits applied to this
 897 attribute, or if no traits have been applied, it returns C<undef>.
 898
 899 =item B<has_applied_traits>
 900
 901 Returns true if this meta-attribute has any traits applied.
 902
 903 =back
 904
 905 =head1 BUGS
 906
 907 All complex software has bugs lurking in it, and this module is no
 908 exception. If you find a bug please either email me, or add the bug
 909 to cpan-RT.
 910
 911 =head1 AUTHOR
 912
 913 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 914
 915 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 916
 917 =head1 COPYRIGHT AND LICENSE
 918
 919 Copyright 2006-2008 by Infinity Interactive, Inc.
 920
 921 L<http://www.iinteractive.com>
 922
 923 This library is free software; you can redistribute it and/or modify
 924 it under the same terms as Perl itself.
 925
 926 =cut