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_01';
  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->get_all_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 class is a subclass of L<Class::MOP::Attribute> that provides
 753 additional Moose-specific functionality.
 754
 755 To really understand this class, you will need to start with the
 756 L<Class::MOP::Attribute> documentation. This class can be understood
 757 as a set of additional features on top of the basic feature provided
 758 by that parent class.
 759
 760 =head1 INHERITANCE
 761
 762 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 763
 764 =head1 METHODS
 765
 766 Many of the documented below override methods in
 767 L<Class::MOP::Attribute> and add Moose specific features.
 768
 769 =head2 Creation
 770
 771 =over 4
 772
 773 =item B<< Moose::Meta::Attribute->new(%options) >>
 774
 775 This method overrides the L<Class::MOP::Attribute> constructor.
 776
 777 Many of the options below are described in more detail in the
 778 L<Moose::Manual::Attributes> document.
 779
 780 It adds the following options to the constructor:
 781
 782 =over 8
 783
 784 =item * is => 'ro' or 'rw'
 785
 786 This provides a shorthand for specifying the C<reader>, C<writer>, or
 787 C<accessor> names. If the attribute is read-only ('ro') then it will
 788 have a C<reader> method with the same attribute as the name.
 789
 790 If it is read-write ('rw') then it will have an C<accessor> method
 791 with the same name. If you provide an explicit C<writer> for a
 792 read-write attribute, then you will have a C<reader> with the same
 793 name as the attribute, and a C<writer> with the name you provided.
 794
 795 =item * isa => $type
 796
 797 This option accepts a type. The type can be a string, which should be
 798 a type name. If the type name is unknown, it is assumed to be a class
 799 name.
 800
 801 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 802
 803 If you I<also> provide a C<does> option, then your C<isa> option must
 804 be a class name, and that class must do the role specified with
 805 C<does>.
 806
 807 =item * does => $role
 808
 809 This is short-hand for saying that the attribute's type must be an
 810 object which does the named role.
 811
 812 =item * coerce => $bool
 813
 814 This option is only valid for objects with a type constraint
 815 (C<isa>). If this is true, then coercions will be applied whenever
 816 this attribute is set.
 817
 818 You can make both this and the C<weak_ref> option true.
 819
 820 =item * trigger => $sub
 821
 822 This option accepts a subroutine reference, which will be called after
 823 the attribute is set.
 824
 825 =item * required => $bool
 826
 827 An attribute which is required must be provided to the constructor. An
 828 attribute which is required can also have a C<default> or C<builder>,
 829 which will satisfy its required-ness.
 830
 831 A required attribute must have a C<default>, C<builder> or a
 832 non-C<undef> C<init_arg>
 833
 834 =item * lazy => $bool
 835
 836 A lazy attribute must have a C<default> or C<builder>. When an
 837 attribute is lazy, the default value will not be calculated until the
 838 attribute is read.
 839
 840 =item * weak_ref => $bool
 841
 842 If this is true, the attribute's value will be stored as a weak
 843 reference.
 844
 845 =item * auto_deref => $bool
 846
 847 If this is true, then the reader will dereference the value when it is
 848 called. The attribute must have a type constraint which defines the
 849 attribute as an array or hash reference.
 850
 851 =item * lazy_build => $bool
 852
 853 Setting this to true makes the attribute lazy and provides a number of
 854 default methods.
 855
 856   has 'size' => (
 857       is         => 'ro',
 858       lazy_build => 1,
 859   );
 860
 861 is equivalent to this:
 862
 863   has 'size' => (
 864       is        => 'ro',
 865       lazy      => 1,
 866       builder   => '_build_size',
 867       clearer   => 'clear_size',
 868       predicate => 'has_size',
 869   );
 870
 871 =item * documentation
 872
 873 An arbitrary string that can be retrieved later by calling C<<
 874 $attr->documentation >>.
 875
 876 =back
 877
 878 =item B<< $attr->clone(%options) >>
 879
 880 This creates a new attribute based on attribute being cloned. You must
 881 supply a C<name> option to provide a new name for the attribute.
 882
 883 The C<%options> can only specify options handled by
 884 L<Class::MOP::Attribute>.
 885
 886 =back
 887
 888 =head2 Value management
 889
 890 =over 4
 891
 892 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 893
 894 This method is used internally to initialize the attribute's slot in
 895 the object C<$instance>.
 896
 897 This overrides the L<Class::MOP::Attribute> method to handle lazy
 898 attributes, weak references, and type constraints.
 899
 900 =item B<get_value>
 901
 902 =item B<set_value>
 903
 904   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 905   if($@) {
 906     print "Oops: $@\n";
 907   }
 908
 909 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 910
 911 Before setting the value, a check is made on the type constraint of
 912 the attribute, if it has one, to see if the value passes it. If the
 913 value fails to pass, the set operation dies with a L<throw_error>.
 914
 915 Any coercion to convert values is done before checking the type constraint.
 916
 917 To check a value against a type constraint before setting it, fetch the
 918 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 919 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 920 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 921 for an example.
 922
 923 =back
 924
 925 =head2 Attribute Accessor generation
 926
 927 =over 4
 928
 929 =item B<< $attr->install_accessors >>
 930
 931 This method overrides the parent to also install delegation methods.
 932
 933 =item B<< $attr->remove_accessors >>
 934
 935 This method overrides the parent to also remove delegation methods.
 936
 937 =item B<< $attr->install_delegation >>
 938
 939 This method adds its delegation methods to the attribute's associated
 940 class, if it has any to add.
 941
 942 =item B<< $attr->remove_delegation >>
 943
 944 This method remove its delegation methods from the attribute's
 945 associated class.
 946
 947 =item B<< $attr->accessor_metaclass >>
 948
 949 Returns the accessor metaclass name, which defaults to
 950 L<Moose::Meta::Method::Accessor>.
 951
 952 =item B<< $attr->delegation_metaclass >>
 953
 954 Returns the delegation metaclass name, which defaults to
 955 L<Moose::Meta::Method::Delegation>.
 956
 957 =back
 958
 959 =head2 Additional Moose features
 960
 961 These methods are not found in the superclass. They support features
 962 provided by Moose.
 963
 964 =over 4
 965
 966 =item B<< $attr->does($role) >>
 967
 968 This indicates whether the I<attribute itself> does the given
 969 role. The role can be given as a full class name, or as a resolvable
 970 trait name.
 971
 972 Note that this checks the attribute itself, not its type constraint,
 973 so it is checking the attribute's metaclass and any traits applied to
 974 the attribute.
 975
 976 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
 977
 978 This is an alternate constructor that handles the C<metaclass> and
 979 C<traits> options.
 980
 981 Effectively, this method is a factory that finds or creates the
 982 appropriate class for the given C<metaclass> and/or C<traits>.
 983
 984 Once it has the appropriate class, it will call C<< $class->new($name,
 985 %options) >> on that class.
 986
 987 =item B<< $attr->clone_and_inherit_options(%options) >>
 988
 989 This method supports the C<has '+foo'> feature. It does various bits
 990 of processing on the supplied C<%options> before ultimately calling
 991 the C<clone> method.
 992
 993 One of its main tasks is to make sure that the C<%options> provided
 994 only includes the options returned by the
 995 C<legal_options_for_inheritance> method.
 996
 997 =item B<< $attr->legal_options_for_inheritance >>
 998
 999 This returns a whitelist of options that can be overridden in a
1000 subclass's attribute definition.
1001
1002 This exists to allow a custom metaclass to change or add to the list
1003 of options which can be changed.
1004
1005 =item B<< $attr->type_constraint >>
1006
1007 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1008 if it has one.
1009
1010 =item B<< $attr->has_type_constraint >>
1011
1012 Returns true if this attribute has a type constraint.
1013
1014 =item B<< $attr->verify_against_type_constraint($value) >>
1015
1016 Given a value, this method returns true if the value is valid for the
1017 attribute's type constraint. If the value is not valid, it throws an
1018 error.
1019
1020 =item B<< $attr->handles >>
1021
1022 This returns the value of the C<handles> option passed to the
1023 constructor.
1024
1025 =item B<< $attr->has_handles >>
1026
1027 Returns true if this attribute performs delegation.
1028
1029 =item B<< $attr->is_weak_ref >>
1030
1031 Returns true if this attribute stores its value as a weak reference.
1032
1033 =item B<< $attr->is_required >>
1034
1035 Returns true if this attribute is required to have a value.
1036
1037 =item B<< $attr->is_lazy >>
1038
1039 Returns true if this attribute is lazy.
1040
1041 =item B<< $attr->is_lazy_build >>
1042
1043 Returns true if the C<lazy_build> option was true when passed to the
1044 constructor.
1045
1046 =item B<< $attr->should_coerce >>
1047
1048 Returns true if the C<coerce> option passed to the constructor was
1049 true.
1050
1051 =item B<< $attr->should_auto_deref >>
1052
1053 Returns true if the C<auto_deref> option passed to the constructor was
1054 true.
1055
1056 =item B<< $attr->trigger >>
1057
1058 This is the subroutine reference that was in the C<trigger> option
1059 passed to the constructor, if any.
1060
1061 =item B<< $attr->has_trigger >>
1062
1063 Returns true if this attribute has a trigger set.
1064
1065 =item B<< $attr->documentation >>
1066
1067 Returns the value that was in the C<documentation> option passed to
1068 the constructor, if any.
1069
1070 =item B<< $attr->has_documentation >>
1071
1072 Returns true if this attribute has any documentation.
1073
1074 =item B<< $attr->applied_traits >>
1075
1076 This returns an array reference of all the traits which were applied
1077 to this attribute. If none were applied, this returns C<undef>.
1078
1079 =item B<< $attr->has_applied_traits >>
1080
1081 Returns true if this attribute has any traits applied.
1082
1083 =back
1084
1085 =head1 BUGS
1086
1087 All complex software has bugs lurking in it, and this module is no
1088 exception. If you find a bug please either email me, or add the bug
1089 to cpan-RT.
1090
1091 =head1 AUTHOR
1092
1093 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1094
1095 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1096
1097 =head1 COPYRIGHT AND LICENSE
1098
1099 Copyright 2006-2009 by Infinity Interactive, Inc.
1100
1101 L<http://www.iinteractive.com>
1102
1103 This library is free software; you can redistribute it and/or modify
1104 it under the same terms as Perl itself.
1105
1106 =cut