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