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 List::MoreUtils 'any';
   9 use Try::Tiny;
  10 use overload     ();
  11
  12 our $VERSION   = '1.07';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use Moose::Meta::Method::Accessor;
  16 use Moose::Meta::Method::Delegation;
  17 use Moose::Util ();
  18 use Moose::Util::TypeConstraints ();
  19
  20 use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
  21
  22 __PACKAGE__->meta->add_attribute('traits' => (
  23     reader    => 'applied_traits',
  24     predicate => 'has_applied_traits',
  25 ));
  26
  27 # we need to have a ->does method in here to
  28 # more easily support traits, and the introspection
  29 # of those traits. We extend the does check to look
  30 # for metatrait aliases.
  31 sub does {
  32     my ($self, $role_name) = @_;
  33     my $name = try {
  34         Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
  35     };
  36     return 0 if !defined($name); # failed to load class
  37     return $self->Moose::Object::does($name);
  38 }
  39
  40 sub throw_error {
  41     my $self = shift;
  42     my $class = ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
  43     unshift @_, "message" if @_ % 2 == 1;
  44     unshift @_, attr => $self if ref $self;
  45     unshift @_, $class;
  46     my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1
  47     goto $handler;
  48 }
  49
  50 sub new {
  51     my ($class, $name, %options) = @_;
  52     $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
  53
  54     delete $options{__hack_no_process_options};
  55
  56     my %attrs =
  57         ( map { $_ => 1 }
  58           grep { defined }
  59           map { $_->init_arg() }
  60           $class->meta()->get_all_attributes()
  61         );
  62
  63     my @bad = sort grep { ! $attrs{$_} }  keys %options;
  64
  65     if (@bad)
  66     {
  67         Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
  68     }
  69
  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         my $i = 0;
 102         while ($i < @$traits) {
 103             my $trait = $traits->[$i++];
 104             next if ref($trait); # options to a trait we discarded
 105
 106             $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
 107                   || $trait;
 108
 109             next if $class->does($trait);
 110
 111             push @traits, $trait;
 112
 113             # are there options?
 114             push @traits, $traits->[$i++]
 115                 if $traits->[$i] && ref($traits->[$i]);
 116         }
 117
 118         if (@traits) {
 119             my $anon_class = Moose::Meta::Class->create_anon_class(
 120                 superclasses => [ $class ],
 121                 roles        => [ @traits ],
 122                 cache        => 1,
 123             );
 124
 125             $class = $anon_class->name;
 126         }
 127     }
 128
 129     return ( wantarray ? ( $class, @traits ) : $class );
 130 }
 131
 132 # ...
 133
 134 my @legal_options_for_inheritance = qw(
 135     default coerce required
 136     documentation lazy handles
 137     builder type_constraint
 138     definition_context
 139     lazy_build weak_ref
 140 );
 141
 142 sub legal_options_for_inheritance { @legal_options_for_inheritance }
 143
 144 # NOTE/TODO
 145 # This method *must* be able to handle
 146 # Class::MOP::Attribute instances as
 147 # well. Yes, I know that is wrong, but
 148 # apparently we didn't realize it was
 149 # doing that and now we have some code
 150 # which is dependent on it. The real
 151 # solution of course is to push this
 152 # feature back up into Class::MOP::Attribute
 153 # but I not right now, I am too lazy.
 154 # However if you are reading this and
 155 # looking for something to do,.. please
 156 # be my guest.
 157 # - stevan
 158 sub clone_and_inherit_options {
 159     my ($self, %options) = @_;
 160
 161     my %copy = %options;
 162
 163     my %actual_options;
 164
 165     # NOTE:
 166     # we may want to extends a Class::MOP::Attribute
 167     # in which case we need to be able to use the
 168     # core set of legal options that have always
 169     # been here. But we allows Moose::Meta::Attribute
 170     # instances to changes them.
 171     # - SL
 172     my @legal_options = $self->can('legal_options_for_inheritance')
 173         ? $self->legal_options_for_inheritance
 174         : @legal_options_for_inheritance;
 175
 176     foreach my $legal_option (@legal_options) {
 177         if (exists $options{$legal_option}) {
 178             $actual_options{$legal_option} = $options{$legal_option};
 179             delete $options{$legal_option};
 180         }
 181     }
 182
 183     if ($options{isa}) {
 184         my $type_constraint;
 185         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
 186             $type_constraint = $options{isa};
 187         }
 188         else {
 189             $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
 190             (defined $type_constraint)
 191                 || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
 192         }
 193
 194         $actual_options{type_constraint} = $type_constraint;
 195         delete $options{isa};
 196     }
 197
 198     if ($options{does}) {
 199         my $type_constraint;
 200         if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
 201             $type_constraint = $options{does};
 202         }
 203         else {
 204             $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
 205             (defined $type_constraint)
 206                 || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
 207         }
 208
 209         $actual_options{type_constraint} = $type_constraint;
 210         delete $options{does};
 211     }
 212
 213     # NOTE:
 214     # this doesn't apply to Class::MOP::Attributes,
 215     # so we can ignore it for them.
 216     # - SL
 217     if ($self->can('interpolate_class')) {
 218         ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
 219
 220         my %seen;
 221         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
 222         $actual_options{traits} = \@all_traits if @all_traits;
 223
 224         delete @options{qw(metaclass traits)};
 225     }
 226
 227     (scalar keys %options == 0)
 228         || $self->throw_error("Illegal inherited options => (" . (join ', ' => keys %options) . ")", data => \%options);
 229
 230
 231     $self->clone(%actual_options);
 232 }
 233
 234 sub clone {
 235     my ( $self, %params ) = @_;
 236
 237     my $class = delete $params{metaclass} || ref $self;
 238
 239     my ( @init, @non_init );
 240
 241     foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
 242         push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
 243     }
 244
 245     my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
 246
 247     my $name = delete $new_params{name};
 248
 249     my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
 250
 251     foreach my $attr ( @non_init ) {
 252         $attr->set_value($clone, $attr->get_value($self));
 253     }
 254
 255     return $clone;
 256 }
 257
 258 sub _process_options {
 259     my ($class, $name, $options) = @_;
 260
 261     if (exists $options->{is}) {
 262
 263         ### -------------------------
 264         ## is => ro, writer => _foo    # turns into (reader => foo, writer => _foo) as before
 265         ## is => rw, writer => _foo    # turns into (reader => foo, writer => _foo)
 266         ## is => rw, accessor => _foo  # turns into (accessor => _foo)
 267         ## is => ro, accessor => _foo  # error, accesor is rw
 268         ### -------------------------
 269
 270         if ($options->{is} eq 'ro') {
 271             $class->throw_error("Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options)
 272                 if exists $options->{accessor};
 273             $options->{reader} ||= $name;
 274         }
 275         elsif ($options->{is} eq 'rw') {
 276             if ($options->{writer}) {
 277                 $options->{reader} ||= $name;
 278             }
 279             else {
 280                 $options->{accessor} ||= $name;
 281             }
 282         }
 283         elsif ($options->{is} eq 'bare') {
 284             # do nothing, but don't complain (later) about missing methods
 285         }
 286         else {
 287             $class->throw_error("I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is});
 288         }
 289     }
 290
 291     if (exists $options->{isa}) {
 292         if (exists $options->{does}) {
 293             if (try { $options->{isa}->can('does') }) {
 294                 ($options->{isa}->does($options->{does}))
 295                     || $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);
 296             }
 297             else {
 298                 $class->throw_error("Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options);
 299             }
 300         }
 301
 302         # allow for anon-subtypes here ...
 303         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 304             $options->{type_constraint} = $options->{isa};
 305         }
 306         else {
 307             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
 308         }
 309     }
 310     elsif (exists $options->{does}) {
 311         # allow for anon-subtypes here ...
 312         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 313                 $options->{type_constraint} = $options->{does};
 314         }
 315         else {
 316             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
 317         }
 318     }
 319
 320     if (exists $options->{coerce} && $options->{coerce}) {
 321         (exists $options->{type_constraint})
 322             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options);
 323         $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)", data => $options)
 324             if $options->{weak_ref};
 325     }
 326
 327     if (exists $options->{trigger}) {
 328         ('CODE' eq ref $options->{trigger})
 329             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
 330     }
 331
 332     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 333         (exists $options->{type_constraint})
 334             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options);
 335         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 336          $options->{type_constraint}->is_a_type_of('HashRef'))
 337             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options);
 338     }
 339
 340     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
 341         $class->throw_error("You can not use lazy_build and default for the same attribute ($name)", data => $options)
 342             if exists $options->{default};
 343         $options->{lazy}      = 1;
 344         $options->{builder} ||= "_build_${name}";
 345         if ($name =~ /^_/) {
 346             $options->{clearer}   ||= "_clear${name}";
 347             $options->{predicate} ||= "_has${name}";
 348         }
 349         else {
 350             $options->{clearer}   ||= "clear_${name}";
 351             $options->{predicate} ||= "has_${name}";
 352         }
 353     }
 354
 355     if (exists $options->{lazy} && $options->{lazy}) {
 356         (exists $options->{default} || defined $options->{builder} )
 357             || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it", data => $options);
 358     }
 359
 360     if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
 361         $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options);
 362     }
 363
 364 }
 365
 366 sub initialize_instance_slot {
 367     my ($self, $meta_instance, $instance, $params) = @_;
 368
 369     $self->initialize_from_params($meta_instance, $instance, $params)
 370         or
 371     $self->initialize_from_defaults($meta_instance, $instance, $params);
 372 }
 373
 374 sub initialize_from_params {
 375     my ($self, $meta_instance, $instance, $params) = @_;
 376
 377     my $init_arg = $self->init_arg();
 378
 379     return unless defined $init_arg;
 380     # try to fetch the init arg from the %params ...
 381
 382     if ( defined($init_arg) and exists $params->{$init_arg}) {
 383         $self->_set_initial_slot_value($meta_instance, $instance, $params->{$init_arg});
 384         return 1;
 385     }
 386     else {
 387         return;
 388     }
 389 }
 390
 391 sub initialize_from_defaults {
 392     my ($self, $meta_instance, $instance, $params) = @_;
 393
 394     # skip it if it's lazy
 395     return if $self->is_lazy;
 396
 397     # attribute's default value (if it has one)
 398     if ($self->has_default) {
 399         $self->_set_initial_slot_value($meta_instance, $instance, scalar($self->default($instance)) );
 400     }
 401     elsif ($self->has_builder) {
 402         $self->_set_initial_slot_value($meta_instance, $instance, scalar($self->_call_builder($instance)) );
 403     }
 404     elsif ( $self->is_required ) {
 405         # die if it's required and doesn't have a default value
 406         $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
 407     }
 408 }
 409
 410 sub _call_builder {
 411     my ( $self, $instance ) = @_;
 412
 413     my $builder = $self->builder();
 414
 415     return $instance->$builder()
 416         if $instance->can( $self->builder );
 417
 418     $self->throw_error(  blessed($instance)
 419             . " does not support builder method '"
 420             . $self->builder
 421             . "' for attribute '"
 422             . $self->name
 423             . "'",
 424             object => $instance,
 425      );
 426 }
 427
 428 ## Slot management
 429
 430 # FIXME:
 431 # this duplicates too much code from
 432 # Class::MOP::Attribute, we need to
 433 # refactor these bits eventually.
 434 # - SL
 435 # the problem is the initializer should get the uncoerced value, and the
 436 # callback should coerce. Otherwise this'd just be
 437 # $self->SUPER::_set_initial_slot_value(..., $self->_coerce_and_verify($value, $instance))
 438 # - YK
 439 sub _set_initial_slot_value {
 440     my ($self, $meta_instance, $instance, $value) = @_;
 441
 442     my $slot_name = $self->name;
 443
 444     if ( $self->has_initializer ) {
 445         my $callback = sub {
 446             my $val = $self->_coerce_and_verify( shift, $instance );;
 447
 448             $meta_instance->set_slot_value($instance, $slot_name, $val);
 449         };
 450
 451         my $initializer = $self->initializer;
 452
 453         # most things will just want to set a value, so make it first arg
 454         $instance->$initializer($value, $callback, $self);
 455     }
 456     else {
 457         my $coerced = $self->_coerce_and_verify( $value, $instance);
 458         $meta_instance->set_slot_value($instance, $slot_name, $coerced);
 459     }
 460
 461     if ( ref $value && $self->is_weak_ref ) {
 462         $self->_weaken_value($instance);
 463     }
 464 }
 465
 466 sub set_value {
 467     my ($self, $instance, @args) = @_;
 468     my $value = $args[0];
 469
 470     my $attr_name = $self->name;
 471
 472     if ($self->is_required and not @args) {
 473         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
 474     }
 475
 476     $value = $self->_coerce_and_verify( $value, $instance );
 477
 478     my @old;
 479     if ( $self->has_trigger && $self->has_value($instance) ) {
 480         @old = $self->get_value($instance, 'for trigger');
 481     }
 482
 483     $self->SUPER::set_value($instance, $value);
 484
 485     if ( ref $value && $self->is_weak_ref ) {
 486         $self->_weaken_value($instance);
 487     }
 488
 489     if ($self->has_trigger) {
 490         $self->trigger->($instance, $value, @old);
 491     }
 492 }
 493
 494 sub _weaken_value {
 495     my ( $self, $instance ) = @_;
 496
 497     my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
 498         ->get_meta_instance;
 499
 500     $meta_instance->weaken_slot_value( $instance, $self->name );
 501 }
 502
 503 sub get_value {
 504     my ($self, $instance, $for_trigger) = @_;
 505
 506     if ($self->is_lazy) {
 507         unless ($self->has_value($instance)) {
 508             my $value;
 509             if ($self->has_default) {
 510                 $value = $self->default($instance);
 511             } elsif ( $self->has_builder ) {
 512                 $value = $self->_call_builder($instance);
 513             }
 514
 515             $value = $self->_coerce_and_verify( $value, $instance );
 516
 517             $self->set_initial_value($instance, $value);
 518         }
 519     }
 520
 521     if ( $self->should_auto_deref && ! $for_trigger ) {
 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             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
 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 _check_associated_methods {
 558     my $self = shift;
 559     unless (
 560         @{ $self->associated_methods }
 561         || ($self->_is_metadata || '') eq 'bare'
 562     ) {
 563         Carp::cluck(
 564             'Attribute (' . $self->name . ') of class '
 565             . $self->associated_class->name
 566             . ' has no associated methods'
 567             . ' (did you mean to provide an "is" argument?)'
 568             . "\n"
 569         )
 570     }
 571 }
 572
 573 sub _process_accessors {
 574     my $self = shift;
 575     my ($type, $accessor, $generate_as_inline_methods) = @_;
 576     $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH';
 577     my $method = $self->associated_class->get_method($accessor);
 578     if ($method && !$method->isa('Class::MOP::Method::Accessor')
 579      && (!$self->definition_context
 580       || $method->package_name eq $self->definition_context->{package})) {
 581         Carp::cluck(
 582             "You are overwriting a locally defined method ($accessor) with "
 583           . "an accessor"
 584         );
 585     }
 586     $self->SUPER::_process_accessors(@_);
 587 }
 588
 589 sub remove_accessors {
 590     my $self = shift;
 591     $self->SUPER::remove_accessors(@_);
 592     $self->remove_delegation if $self->has_handles;
 593     return;
 594 }
 595
 596 sub install_delegation {
 597     my $self = shift;
 598
 599     # NOTE:
 600     # Here we canonicalize the 'handles' option
 601     # this will sort out any details and always
 602     # return an hash of methods which we want
 603     # to delagate to, see that method for details
 604     my %handles = $self->_canonicalize_handles;
 605
 606
 607     # install the delegation ...
 608     my $associated_class = $self->associated_class;
 609     foreach my $handle (keys %handles) {
 610         my $method_to_call = $handles{$handle};
 611         my $class_name = $associated_class->name;
 612         my $name = "${class_name}::${handle}";
 613
 614             (!$associated_class->has_method($handle))
 615                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 616
 617         # NOTE:
 618         # handles is not allowed to delegate
 619         # any of these methods, as they will
 620         # override the ones in your class, which
 621         # is almost certainly not what you want.
 622
 623         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 624         #cluck("Not delegating method '$handle' because it is a core method") and
 625         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 626
 627         my $method = $self->_make_delegation_method($handle, $method_to_call);
 628
 629         $self->associated_class->add_method($method->name, $method);
 630         $self->associate_method($method);
 631     }
 632 }
 633
 634 sub remove_delegation {
 635     my $self = shift;
 636     my %handles = $self->_canonicalize_handles;
 637     my $associated_class = $self->associated_class;
 638     foreach my $handle (keys %handles) {
 639         next unless any { $handle eq $_ }
 640                     map { $_->name }
 641                     @{ $self->associated_methods };
 642         $self->associated_class->remove_method($handle);
 643     }
 644 }
 645
 646 # private methods to help delegation ...
 647
 648 sub _canonicalize_handles {
 649     my $self    = shift;
 650     my $handles = $self->handles;
 651     if (my $handle_type = ref($handles)) {
 652         if ($handle_type eq 'HASH') {
 653             return %{$handles};
 654         }
 655         elsif ($handle_type eq 'ARRAY') {
 656             return map { $_ => $_ } @{$handles};
 657         }
 658         elsif ($handle_type eq 'Regexp') {
 659             ($self->has_type_constraint)
 660                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 661             return map  { ($_ => $_) }
 662                    grep { /$handles/ } $self->_get_delegate_method_list;
 663         }
 664         elsif ($handle_type eq 'CODE') {
 665             return $handles->($self, $self->_find_delegate_metaclass);
 666         }
 667         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
 668             return map { $_ => $_ } @{ $handles->methods };
 669         }
 670         elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
 671             $handles = $handles->role;
 672         }
 673         else {
 674             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 675         }
 676     }
 677
 678     Class::MOP::load_class($handles);
 679     my $role_meta = Class::MOP::class_of($handles);
 680
 681     (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 682         || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 683
 684     return map { $_ => $_ }
 685         grep { $_ ne 'meta' } (
 686         $role_meta->get_method_list,
 687         map { $_->name } $role_meta->get_required_method_list,
 688         );
 689 }
 690
 691 sub _find_delegate_metaclass {
 692     my $self = shift;
 693     if (my $class = $self->_isa_metadata) {
 694         # we might be dealing with a non-Moose class,
 695         # and need to make our own metaclass. if there's
 696         # already a metaclass, it will be returned
 697         return Class::MOP::Class->initialize($class);
 698     }
 699     elsif (my $role = $self->_does_metadata) {
 700         return Class::MOP::class_of($role);
 701     }
 702     else {
 703         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 704     }
 705 }
 706
 707 sub _get_delegate_method_list {
 708     my $self = shift;
 709     my $meta = $self->_find_delegate_metaclass;
 710     if ($meta->isa('Class::MOP::Class')) {
 711         return map  { $_->name }  # NOTE: !never! delegate &meta
 712                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 713                     $meta->get_all_methods;
 714     }
 715     elsif ($meta->isa('Moose::Meta::Role')) {
 716         return $meta->get_method_list;
 717     }
 718     else {
 719         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 720     }
 721 }
 722
 723 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 724
 725 sub _make_delegation_method {
 726     my ( $self, $handle_name, $method_to_call ) = @_;
 727
 728     my @curried_arguments;
 729
 730     ($method_to_call, @curried_arguments) = @$method_to_call
 731         if 'ARRAY' eq ref($method_to_call);
 732
 733     return $self->delegation_metaclass->new(
 734         name               => $handle_name,
 735         package_name       => $self->associated_class->name,
 736         attribute          => $self,
 737         delegate_to_method => $method_to_call,
 738         curried_arguments  => \@curried_arguments,
 739     );
 740 }
 741
 742 sub _coerce_and_verify {
 743     my $self     = shift;
 744     my $val      = shift;
 745     my $instance = shift;
 746
 747     return $val unless $self->has_type_constraint;
 748
 749     my $type_constraint = $self->type_constraint;
 750     if ($self->should_coerce && $type_constraint->has_coercion) {
 751         $val = $type_constraint->coerce($val);
 752     }
 753
 754     $self->verify_against_type_constraint($val, instance => $instance);
 755
 756     return $val;
 757 }
 758
 759 sub verify_against_type_constraint {
 760     my $self = shift;
 761     my $val  = shift;
 762
 763     return 1 if !$self->has_type_constraint;
 764
 765     my $type_constraint = $self->type_constraint;
 766
 767     $type_constraint->check($val)
 768         || $self->throw_error("Attribute ("
 769                  . $self->name
 770                  . ") does not pass the type constraint because: "
 771                  . $type_constraint->get_message($val), data => $val, @_);
 772 }
 773
 774 package Moose::Meta::Attribute::Custom::Moose;
 775 sub register_implementation { 'Moose::Meta::Attribute' }
 776
 777 1;
 778
 779 __END__
 780
 781 =pod
 782
 783 =head1 NAME
 784
 785 Moose::Meta::Attribute - The Moose attribute metaclass
 786
 787 =head1 DESCRIPTION
 788
 789 This class is a subclass of L<Class::MOP::Attribute> that provides
 790 additional Moose-specific functionality.
 791
 792 To really understand this class, you will need to start with the
 793 L<Class::MOP::Attribute> documentation. This class can be understood
 794 as a set of additional features on top of the basic feature provided
 795 by that parent class.
 796
 797 =head1 INHERITANCE
 798
 799 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 800
 801 =head1 METHODS
 802
 803 Many of the documented below override methods in
 804 L<Class::MOP::Attribute> and add Moose specific features.
 805
 806 =head2 Creation
 807
 808 =over 4
 809
 810 =item B<< Moose::Meta::Attribute->new(%options) >>
 811
 812 This method overrides the L<Class::MOP::Attribute> constructor.
 813
 814 Many of the options below are described in more detail in the
 815 L<Moose::Manual::Attributes> document.
 816
 817 It adds the following options to the constructor:
 818
 819 =over 8
 820
 821 =item * is => 'ro', 'rw', 'bare'
 822
 823 This provides a shorthand for specifying the C<reader>, C<writer>, or
 824 C<accessor> names. If the attribute is read-only ('ro') then it will
 825 have a C<reader> method with the same attribute as the name.
 826
 827 If it is read-write ('rw') then it will have an C<accessor> method
 828 with the same name. If you provide an explicit C<writer> for a
 829 read-write attribute, then you will have a C<reader> with the same
 830 name as the attribute, and a C<writer> with the name you provided.
 831
 832 Use 'bare' when you are deliberately not installing any methods
 833 (accessor, reader, etc.) associated with this attribute; otherwise,
 834 Moose will issue a deprecation warning when this attribute is added to a
 835 metaclass.
 836
 837 =item * isa => $type
 838
 839 This option accepts a type. The type can be a string, which should be
 840 a type name. If the type name is unknown, it is assumed to be a class
 841 name.
 842
 843 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 844
 845 If you I<also> provide a C<does> option, then your C<isa> option must
 846 be a class name, and that class must do the role specified with
 847 C<does>.
 848
 849 =item * does => $role
 850
 851 This is short-hand for saying that the attribute's type must be an
 852 object which does the named role.
 853
 854 =item * coerce => $bool
 855
 856 This option is only valid for objects with a type constraint
 857 (C<isa>). If this is true, then coercions will be applied whenever
 858 this attribute is set.
 859
 860 You can make both this and the C<weak_ref> option true.
 861
 862 =item * trigger => $sub
 863
 864 This option accepts a subroutine reference, which will be called after
 865 the attribute is set.
 866
 867 =item * required => $bool
 868
 869 An attribute which is required must be provided to the constructor. An
 870 attribute which is required can also have a C<default> or C<builder>,
 871 which will satisfy its required-ness.
 872
 873 A required attribute must have a C<default>, C<builder> or a
 874 non-C<undef> C<init_arg>
 875
 876 =item * lazy => $bool
 877
 878 A lazy attribute must have a C<default> or C<builder>. When an
 879 attribute is lazy, the default value will not be calculated until the
 880 attribute is read.
 881
 882 =item * weak_ref => $bool
 883
 884 If this is true, the attribute's value will be stored as a weak
 885 reference.
 886
 887 =item * auto_deref => $bool
 888
 889 If this is true, then the reader will dereference the value when it is
 890 called. The attribute must have a type constraint which defines the
 891 attribute as an array or hash reference.
 892
 893 =item * lazy_build => $bool
 894
 895 Setting this to true makes the attribute lazy and provides a number of
 896 default methods.
 897
 898   has 'size' => (
 899       is         => 'ro',
 900       lazy_build => 1,
 901   );
 902
 903 is equivalent to this:
 904
 905   has 'size' => (
 906       is        => 'ro',
 907       lazy      => 1,
 908       builder   => '_build_size',
 909       clearer   => 'clear_size',
 910       predicate => 'has_size',
 911   );
 912
 913 =item * documentation
 914
 915 An arbitrary string that can be retrieved later by calling C<<
 916 $attr->documentation >>.
 917
 918 =back
 919
 920 =item B<< $attr->clone(%options) >>
 921
 922 This creates a new attribute based on attribute being cloned. You must
 923 supply a C<name> option to provide a new name for the attribute.
 924
 925 The C<%options> can only specify options handled by
 926 L<Class::MOP::Attribute>.
 927
 928 =back
 929
 930 =head2 Value management
 931
 932 =over 4
 933
 934 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 935
 936 This method is used internally to initialize the attribute's slot in
 937 the object C<$instance>.
 938
 939 This overrides the L<Class::MOP::Attribute> method to handle lazy
 940 attributes, weak references, and type constraints.
 941
 942 =item B<get_value>
 943
 944 =item B<set_value>
 945
 946   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 947   if($@) {
 948     print "Oops: $@\n";
 949   }
 950
 951 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 952
 953 Before setting the value, a check is made on the type constraint of
 954 the attribute, if it has one, to see if the value passes it. If the
 955 value fails to pass, the set operation dies with a L</throw_error>.
 956
 957 Any coercion to convert values is done before checking the type constraint.
 958
 959 To check a value against a type constraint before setting it, fetch the
 960 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 961 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 962 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 963 for an example.
 964
 965 =back
 966
 967 =head2 Attribute Accessor generation
 968
 969 =over 4
 970
 971 =item B<< $attr->install_accessors >>
 972
 973 This method overrides the parent to also install delegation methods.
 974
 975 If, after installing all methods, the attribute object has no associated
 976 methods, it throws an error unless C<< is => 'bare' >> was passed to the
 977 attribute constructor.  (Trying to add an attribute that has no associated
 978 methods is almost always an error.)
 979
 980 =item B<< $attr->remove_accessors >>
 981
 982 This method overrides the parent to also remove delegation methods.
 983
 984 =item B<< $attr->install_delegation >>
 985
 986 This method adds its delegation methods to the attribute's associated
 987 class, if it has any to add.
 988
 989 =item B<< $attr->remove_delegation >>
 990
 991 This method remove its delegation methods from the attribute's
 992 associated class.
 993
 994 =item B<< $attr->accessor_metaclass >>
 995
 996 Returns the accessor metaclass name, which defaults to
 997 L<Moose::Meta::Method::Accessor>.
 998
 999 =item B<< $attr->delegation_metaclass >>
1000
1001 Returns the delegation metaclass name, which defaults to
1002 L<Moose::Meta::Method::Delegation>.
1003
1004 =back
1005
1006 =head2 Additional Moose features
1007
1008 These methods are not found in the superclass. They support features
1009 provided by Moose.
1010
1011 =over 4
1012
1013 =item B<< $attr->does($role) >>
1014
1015 This indicates whether the I<attribute itself> does the given
1016 role. The role can be given as a full class name, or as a resolvable
1017 trait name.
1018
1019 Note that this checks the attribute itself, not its type constraint,
1020 so it is checking the attribute's metaclass and any traits applied to
1021 the attribute.
1022
1023 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
1024
1025 This is an alternate constructor that handles the C<metaclass> and
1026 C<traits> options.
1027
1028 Effectively, this method is a factory that finds or creates the
1029 appropriate class for the given C<metaclass> and/or C<traits>.
1030
1031 Once it has the appropriate class, it will call C<< $class->new($name,
1032 %options) >> on that class.
1033
1034 =item B<< $attr->clone_and_inherit_options(%options) >>
1035
1036 This method supports the C<has '+foo'> feature. It does various bits
1037 of processing on the supplied C<%options> before ultimately calling
1038 the C<clone> method.
1039
1040 One of its main tasks is to make sure that the C<%options> provided
1041 only includes the options returned by the
1042 C<legal_options_for_inheritance> method.
1043
1044 =item B<< $attr->legal_options_for_inheritance >>
1045
1046 This returns a whitelist of options that can be overridden in a
1047 subclass's attribute definition.
1048
1049 This exists to allow a custom metaclass to change or add to the list
1050 of options which can be changed.
1051
1052 =item B<< $attr->type_constraint >>
1053
1054 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
1055 if it has one.
1056
1057 =item B<< $attr->has_type_constraint >>
1058
1059 Returns true if this attribute has a type constraint.
1060
1061 =item B<< $attr->verify_against_type_constraint($value) >>
1062
1063 Given a value, this method returns true if the value is valid for the
1064 attribute's type constraint. If the value is not valid, it throws an
1065 error.
1066
1067 =item B<< $attr->handles >>
1068
1069 This returns the value of the C<handles> option passed to the
1070 constructor.
1071
1072 =item B<< $attr->has_handles >>
1073
1074 Returns true if this attribute performs delegation.
1075
1076 =item B<< $attr->is_weak_ref >>
1077
1078 Returns true if this attribute stores its value as a weak reference.
1079
1080 =item B<< $attr->is_required >>
1081
1082 Returns true if this attribute is required to have a value.
1083
1084 =item B<< $attr->is_lazy >>
1085
1086 Returns true if this attribute is lazy.
1087
1088 =item B<< $attr->is_lazy_build >>
1089
1090 Returns true if the C<lazy_build> option was true when passed to the
1091 constructor.
1092
1093 =item B<< $attr->should_coerce >>
1094
1095 Returns true if the C<coerce> option passed to the constructor was
1096 true.
1097
1098 =item B<< $attr->should_auto_deref >>
1099
1100 Returns true if the C<auto_deref> option passed to the constructor was
1101 true.
1102
1103 =item B<< $attr->trigger >>
1104
1105 This is the subroutine reference that was in the C<trigger> option
1106 passed to the constructor, if any.
1107
1108 =item B<< $attr->has_trigger >>
1109
1110 Returns true if this attribute has a trigger set.
1111
1112 =item B<< $attr->documentation >>
1113
1114 Returns the value that was in the C<documentation> option passed to
1115 the constructor, if any.
1116
1117 =item B<< $attr->has_documentation >>
1118
1119 Returns true if this attribute has any documentation.
1120
1121 =item B<< $attr->applied_traits >>
1122
1123 This returns an array reference of all the traits which were applied
1124 to this attribute. If none were applied, this returns C<undef>.
1125
1126 =item B<< $attr->has_applied_traits >>
1127
1128 Returns true if this attribute has any traits applied.
1129
1130 =back
1131
1132 =head1 BUGS
1133
1134 See L<Moose/BUGS> for details on reporting bugs.
1135
1136 =head1 AUTHOR
1137
1138 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1139
1140 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1141
1142 =head1 COPYRIGHT AND LICENSE
1143
1144 Copyright 2006-2010 by Infinity Interactive, Inc.
1145
1146 L<http://www.iinteractive.com>
1147
1148 This library is free software; you can redistribute it and/or modify
1149 it under the same terms as Perl itself.
1150
1151 =cut