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.73';
  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) } Class::MOP::class_of($self)->compute_all_applicable_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     $val = $self->_coerce_and_verify( $val, $instance );
 407
 408     $self->set_initial_value($instance, $val);
 409     $meta_instance->weaken_slot_value($instance, $self->name)
 410         if ref $val && $self->is_weak_ref;
 411 }
 412
 413 sub _call_builder {
 414     my ( $self, $instance ) = @_;
 415
 416     my $builder = $self->builder();
 417
 418     return $instance->$builder()
 419         if $instance->can( $self->builder );
 420
 421     $self->throw_error(  blessed($instance)
 422             . " does not support builder method '"
 423             . $self->builder
 424             . "' for attribute '"
 425             . $self->name
 426             . "'",
 427             object => $instance,
 428      );
 429 }
 430
 431 ## Slot management
 432
 433 # FIXME:
 434 # this duplicates too much code from
 435 # Class::MOP::Attribute, we need to
 436 # refactor these bits eventually.
 437 # - SL
 438 sub _set_initial_slot_value {
 439     my ($self, $meta_instance, $instance, $value) = @_;
 440
 441     my $slot_name = $self->name;
 442
 443     return $meta_instance->set_slot_value($instance, $slot_name, $value)
 444         unless $self->has_initializer;
 445
 446     my ($type_constraint, $can_coerce);
 447     if ($self->has_type_constraint) {
 448         $type_constraint = $self->type_constraint;
 449         $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
 450     }
 451
 452     my $callback = sub {
 453         my $val = $self->_coerce_and_verify( shift, $instance );;
 454
 455         $meta_instance->set_slot_value($instance, $slot_name, $val);
 456     };
 457
 458     my $initializer = $self->initializer;
 459
 460     # most things will just want to set a value, so make it first arg
 461     $instance->$initializer($value, $callback, $self);
 462 }
 463
 464 sub set_value {
 465     my ($self, $instance, @args) = @_;
 466     my $value = $args[0];
 467
 468     my $attr_name = $self->name;
 469
 470     if ($self->is_required and not @args) {
 471         $self->throw_error("Attribute ($attr_name) is required", object => $instance);
 472     }
 473
 474     $value = $self->_coerce_and_verify( $value, $instance );
 475
 476     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 477                                          ->get_meta_instance;
 478
 479     $meta_instance->set_slot_value($instance, $attr_name, $value);
 480
 481     if (ref $value && $self->is_weak_ref) {
 482         $meta_instance->weaken_slot_value($instance, $attr_name);
 483     }
 484
 485     if ($self->has_trigger) {
 486         $self->trigger->($instance, $value);
 487     }
 488 }
 489
 490 sub get_value {
 491     my ($self, $instance) = @_;
 492
 493     if ($self->is_lazy) {
 494         unless ($self->has_value($instance)) {
 495             my $value;
 496             if ($self->has_default) {
 497                 $value = $self->default($instance);
 498             } elsif ( $self->has_builder ) {
 499                 $value = $self->_call_builder($instance);
 500             }
 501
 502             $value = $self->_coerce_and_verify( $value, $instance );
 503
 504             $self->set_initial_value($instance, $value);
 505         }
 506     }
 507
 508     if ($self->should_auto_deref) {
 509
 510         my $type_constraint = $self->type_constraint;
 511
 512         if ($type_constraint->is_a_type_of('ArrayRef')) {
 513             my $rv = $self->SUPER::get_value($instance);
 514             return unless defined $rv;
 515             return wantarray ? @{ $rv } : $rv;
 516         }
 517         elsif ($type_constraint->is_a_type_of('HashRef')) {
 518             my $rv = $self->SUPER::get_value($instance);
 519             return unless defined $rv;
 520             return wantarray ? %{ $rv } : $rv;
 521         }
 522         else {
 523             $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
 524         }
 525
 526     }
 527     else {
 528
 529         return $self->SUPER::get_value($instance);
 530     }
 531 }
 532
 533 ## installing accessors
 534
 535 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 536
 537 sub install_accessors {
 538     my $self = shift;
 539     $self->SUPER::install_accessors(@_);
 540     $self->install_delegation if $self->has_handles;
 541     return;
 542 }
 543
 544 sub remove_accessors {
 545     my $self = shift;
 546     $self->SUPER::remove_accessors(@_);
 547     $self->remove_delegation if $self->has_handles;
 548     return;
 549 }
 550
 551 sub install_delegation {
 552     my $self = shift;
 553
 554     # NOTE:
 555     # Here we canonicalize the 'handles' option
 556     # this will sort out any details and always
 557     # return an hash of methods which we want
 558     # to delagate to, see that method for details
 559     my %handles = $self->_canonicalize_handles;
 560
 561
 562     # install the delegation ...
 563     my $associated_class = $self->associated_class;
 564     foreach my $handle (keys %handles) {
 565         my $method_to_call = $handles{$handle};
 566         my $class_name = $associated_class->name;
 567         my $name = "${class_name}::${handle}";
 568
 569             (!$associated_class->has_method($handle))
 570                 || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
 571
 572         # NOTE:
 573         # handles is not allowed to delegate
 574         # any of these methods, as they will
 575         # override the ones in your class, which
 576         # is almost certainly not what you want.
 577
 578         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 579         #cluck("Not delegating method '$handle' because it is a core method") and
 580         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 581
 582         my $method = $self->_make_delegation_method($handle, $method_to_call);
 583
 584         $self->associated_class->add_method($method->name, $method);
 585     }
 586 }
 587
 588 sub remove_delegation {
 589     my $self = shift;
 590     my %handles = $self->_canonicalize_handles;
 591     my $associated_class = $self->associated_class;
 592     foreach my $handle (keys %handles) {
 593         $self->associated_class->remove_method($handle);
 594     }
 595 }
 596
 597 # private methods to help delegation ...
 598
 599 sub _canonicalize_handles {
 600     my $self    = shift;
 601     my $handles = $self->handles;
 602     if (my $handle_type = ref($handles)) {
 603         if ($handle_type eq 'HASH') {
 604             return %{$handles};
 605         }
 606         elsif ($handle_type eq 'ARRAY') {
 607             return map { $_ => $_ } @{$handles};
 608         }
 609         elsif ($handle_type eq 'Regexp') {
 610             ($self->has_type_constraint)
 611                 || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
 612             return map  { ($_ => $_) }
 613                    grep { /$handles/ } $self->_get_delegate_method_list;
 614         }
 615         elsif ($handle_type eq 'CODE') {
 616             return $handles->($self, $self->_find_delegate_metaclass);
 617         }
 618         else {
 619             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
 620         }
 621     }
 622     else {
 623         Class::MOP::load_class($handles)
 624             unless Class::MOP::is_class_loaded($handles);
 625
 626         my $role_meta = Class::MOP::class_of($handles);
 627
 628         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 629             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 630
 631         return map { $_ => $_ } (
 632             $role_meta->get_method_list,
 633             $role_meta->get_required_method_list
 634         );
 635     }
 636 }
 637
 638 sub _find_delegate_metaclass {
 639     my $self = shift;
 640     if (my $class = $self->_isa_metadata) {
 641         # if the class does have
 642         # a meta method, use it
 643         return $class->meta if $class->can('meta');
 644         # otherwise we might be
 645         # dealing with a non-Moose
 646         # class, and need to make
 647         # our own metaclass
 648         return Moose::Meta::Class->initialize($class);
 649     }
 650     elsif (my $role = $self->_does_metadata) {
 651         # our role will always have
 652         # a meta method
 653         return $role->meta;
 654     }
 655     else {
 656         $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
 657     }
 658 }
 659
 660 sub _get_delegate_method_list {
 661     my $self = shift;
 662     my $meta = $self->_find_delegate_metaclass;
 663     if ($meta->isa('Class::MOP::Class')) {
 664         return map  { $_->name }  # NOTE: !never! delegate &meta
 665                grep { $_->package_name ne 'Moose::Object' && $_->name ne 'meta' }
 666                     $meta->get_all_methods;
 667     }
 668     elsif ($meta->isa('Moose::Meta::Role')) {
 669         return $meta->get_method_list;
 670     }
 671     else {
 672         $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
 673     }
 674 }
 675
 676 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 677
 678 sub _make_delegation_method {
 679     my ( $self, $handle_name, $method_to_call ) = @_;
 680
 681     my $method_body;
 682
 683     $method_body = $method_to_call
 684         if 'CODE' eq ref($method_to_call);
 685
 686     return $self->delegation_metaclass->new(
 687         name               => $handle_name,
 688         package_name       => $self->associated_class->name,
 689         attribute          => $self,
 690         delegate_to_method => $method_to_call,
 691     );
 692 }
 693
 694 sub _coerce_and_verify {
 695     my $self     = shift;
 696     my $val      = shift;
 697     my $instance = shift;
 698
 699     return $val unless $self->has_type_constraint;
 700
 701     my $type_constraint = $self->type_constraint;
 702     if ($self->should_coerce && $type_constraint->has_coercion) {
 703         $val = $type_constraint->coerce($val);
 704     }
 705
 706     $self->verify_against_type_constraint($val, instance => $instance);
 707
 708     return $val;
 709 }
 710
 711 sub verify_against_type_constraint {
 712     my $self = shift;
 713     my $val  = shift;
 714
 715     return 1 if !$self->has_type_constraint;
 716
 717     my $type_constraint = $self->type_constraint;
 718
 719     $type_constraint->check($val)
 720         || $self->throw_error("Attribute ("
 721                  . $self->name
 722                  . ") does not pass the type constraint because: "
 723                  . $type_constraint->get_message($val), data => $val, @_);
 724 }
 725
 726 package Moose::Meta::Attribute::Custom::Moose;
 727 sub register_implementation { 'Moose::Meta::Attribute' }
 728
 729 1;
 730
 731 __END__
 732
 733 =pod
 734
 735 =head1 NAME
 736
 737 Moose::Meta::Attribute - The Moose attribute metaclass
 738
 739 =head1 DESCRIPTION
 740
 741 This class is a subclass of L<Class::MOP::Attribute> that provides
 742 additional Moose-specific functionality.
 743
 744 To really understand this class, you will need to start with the
 745 L<Class::MOP::Attribute> documentation. This class can be understood
 746 as a set of additional features on top of the basic feature provided
 747 by that parent class.
 748
 749 =head1 INHERITANCE
 750
 751 C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
 752
 753 =head1 METHODS
 754
 755 Many of the documented below override methods in
 756 L<Class::MOP::Attribute> and add Moose specific features.
 757
 758 =head2 Creation
 759
 760 =over 4
 761
 762 =item B<< Moose::Meta::Attribute->new(%options) >>
 763
 764 This method overrides the L<Class::MOP::Attribute> constructor.
 765
 766 Many of the options below are described in more detail in the
 767 L<Moose::Manual::Attributes> document.
 768
 769 It adds the following options to the constructor:
 770
 771 =over 8
 772
 773 =item * is => 'ro' or 'rw'
 774
 775 This provides a shorthand for specifying the C<reader>, C<writer>, or
 776 C<accessor> names. If the attribute is read-only ('ro') then it will
 777 have a C<reader> method with the same attribute as the name.
 778
 779 If it is read-write ('rw') then it will have an C<accessor> method
 780 with the same name. If you provide an explicit C<writer> for a
 781 read-write attribute, then you will have a C<reader> with the same
 782 name as the attribute, and a C<writer> with the name you provided.
 783
 784 =item * isa => $type
 785
 786 This option accepts a type. The type can be a string, which should be
 787 a type name. If the type name is unknown, it is assumed to be a class
 788 name.
 789
 790 This option can also accept a L<Moose::Meta::TypeConstraint> object.
 791
 792 If you I<also> provide a C<does> option, then your C<isa> option must
 793 be a class name, and that class must do the role specified with
 794 C<does>.
 795
 796 =item * does => $role
 797
 798 This is short-hand for saying that the attribute's type must be an
 799 object which does the named role.
 800
 801 =item * coerce => $bool
 802
 803 This option is only valid for objects with a type constraint
 804 (C<isa>). If this is true, then coercions will be applied whenever
 805 this attribute is set.
 806
 807 You can make both this and the C<weak_ref> option true.
 808
 809 =item * trigger => $sub
 810
 811 This option accepts a subroutine reference, which will be called after
 812 the attribute is set.
 813
 814 =item * required => $bool
 815
 816 An attribute which is required must be provided to the constructor. An
 817 attribute which is required can also have a C<default> or C<builder>,
 818 which will satisfy its required-ness.
 819
 820 A required attribute must have a C<default>, C<builder> or a
 821 non-C<undef> C<init_arg>
 822
 823 =item * lazy => $bool
 824
 825 A lazy attribute must have a C<default> or C<builder>. When an
 826 attribute is lazy, the default value will not be calculated until the
 827 attribute is read.
 828
 829 =item * weak_ref => $bool
 830
 831 If this is true, the attribute's value will be stored as a weak
 832 reference.
 833
 834 =item * auto_deref => $bool
 835
 836 If this is true, then the reader will dereference the value when it is
 837 called. The attribute must have a type constraint which defines the
 838 attribute as an array or hash reference.
 839
 840 =item * lazy_build => $bool
 841
 842 Setting this to true makes the attribute lazy and provides a number of
 843 default methods.
 844
 845   has 'size' => (
 846       is         => 'ro',
 847       lazy_build => 1,
 848   );
 849
 850 is equivalent to this:
 851
 852   has 'size' => (
 853       is        => 'ro',
 854       lazy      => 1,
 855       builder   => '_build_size',
 856       clearer   => 'clear_size',
 857       predicate => 'has_size',
 858   );
 859
 860 =item * documentation
 861
 862 An arbitrary string that can be retrieved later by calling C<<
 863 $attr->documentation >>.
 864
 865 =back
 866
 867 =item B<< $attr->clone(%options) >>
 868
 869 This creates a new attribute based on attribute being cloned. You must
 870 supply a C<name> option to provide a new name for the attribute.
 871
 872 The C<%options> can only specify options handled by
 873 L<Class::MOP::Attribute>.
 874
 875 =back
 876
 877 =head2 Value management
 878
 879 =over 4
 880
 881 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
 882
 883 This method is used internally to initialize the attribute's slot in
 884 the object C<$instance>.
 885
 886 This overrides the L<Class::MOP::Attribute> method to handle lazy
 887 attributes, weak references, and type constraints.
 888
 889 =item B<get_value>
 890
 891 =item B<set_value>
 892
 893   eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
 894   if($@) {
 895     print "Oops: $@\n";
 896   }
 897
 898 I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
 899
 900 Before setting the value, a check is made on the type constraint of
 901 the attribute, if it has one, to see if the value passes it. If the
 902 value fails to pass, the set operation dies with a L<throw_error>.
 903
 904 Any coercion to convert values is done before checking the type constraint.
 905
 906 To check a value against a type constraint before setting it, fetch the
 907 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 908 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 909 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
 910 for an example.
 911
 912 =back
 913
 914 =head2 Attribute Accessor generation
 915
 916 =over 4
 917
 918 =item B<< $attr->install_accessors >>
 919
 920 This method overrides the parent to also install delegation methods.
 921
 922 =item B<< $attr->remove_accessors >>
 923
 924 This method overrides the parent to also remove delegation methods.
 925
 926 =item B<< $attr->install_delegation >>
 927
 928 This method adds its delegation methods to the attribute's associated
 929 class, if it has any to add.
 930
 931 =item B<< $attr->remove_delegation >>
 932
 933 This method remove its delegation methods from the attribute's
 934 associated class.
 935
 936 =item B<< $attr->accessor_metaclass >>
 937
 938 Returns the accessor metaclass name, which defaults to
 939 L<Moose::Meta::Method::Accessor>.
 940
 941 =item B<< $attr->delegation_metaclass >>
 942
 943 Returns the delegation metaclass name, which defaults to
 944 L<Moose::Meta::Method::Delegation>.
 945
 946 =back
 947
 948 =head2 Additional Moose features
 949
 950 These methods are not found in the superclass. They support features
 951 provided by Moose.
 952
 953 =over 4
 954
 955 =item B<< $attr->does($role) >>
 956
 957 This indicates whether the I<attribute itself> does the given
 958 role. The role can be given as a full class name, or as a resolvable
 959 trait name.
 960
 961 Note that this checks the attribute itself, not its type constraint,
 962 so it is checking the attribute's metaclass and any traits applied to
 963 the attribute.
 964
 965 =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
 966
 967 This is an alternate constructor that handles the C<metaclass> and
 968 C<traits> options.
 969
 970 Effectively, this method is a factory that finds or creates the
 971 appropriate class for the given C<metaclass> and/or C<traits>.
 972
 973 Once it has the appropriate class, it will call C<< $class->new($name,
 974 %options) >> on that class.
 975
 976 =item B<< $attr->clone_and_inherit_options(%options) >>
 977
 978 This method supports the C<has '+foo'> feature. It does various bits
 979 of processing on the supplied C<%options> before ultimately calling
 980 the C<clone> method.
 981
 982 One of its main tasks is to make sure that the C<%options> provided
 983 only includes the options returned by the
 984 C<legal_options_for_inheritance> method.
 985
 986 =item B<< $attr->legal_options_for_inheritance >>
 987
 988 This returns a whitelist of options that can be overridden in a
 989 subclass's attribute definition.
 990
 991 This exists to allow a custom metaclass to change or add to the list
 992 of options which can be changed.
 993
 994 =item B<< $attr->type_constraint >>
 995
 996 Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
 997 if it has one.
 998
 999 =item B<< $attr->has_type_constraint >>
1000
1001 Returns true if this attribute has a type constraint.
1002
1003 =item B<< $attr->verify_against_type_constraint($value) >>
1004
1005 Given a value, this method returns true if the value is valid for the
1006 attribute's type constraint. If the value is not valid, it throws an
1007 error.
1008
1009 =item B<< $attr->handles >>
1010
1011 This returns the value of the C<handles> option passed to the
1012 constructor.
1013
1014 =item B<< $attr->has_handles >>
1015
1016 Returns true if this attribute performs delegation.
1017
1018 =item B<< $attr->is_weak_ref >>
1019
1020 Returns true if this attribute stores its value as a weak reference.
1021
1022 =item B<< $attr->is_required >>
1023
1024 Returns true if this attribute is required to have a value.
1025
1026 =item B<< $attr->is_lazy >>
1027
1028 Returns true if this attribute is lazy.
1029
1030 =item B<< $attr->is_lazy_build >>
1031
1032 Returns true if the C<lazy_build> option was true when passed to the
1033 constructor.
1034
1035 =item B<< $attr->should_coerce >>
1036
1037 Returns true if the C<coerce> option passed to the constructor was
1038 true.
1039
1040 =item B<< $attr->should_auto_deref >>
1041
1042 Returns true if the C<auto_deref> option passed to the constructor was
1043 true.
1044
1045 =item B<< $attr->trigger >>
1046
1047 This is the subroutine reference that was in the C<trigger> option
1048 passed to the constructor, if any.
1049
1050 =item B<< $attr->has_trigger >>
1051
1052 Returns true if this attribute has a trigger set.
1053
1054 =item B<< $attr->documentation >>
1055
1056 Returns the value that was in the C<documentation> option passed to
1057 the constructor, if any.
1058
1059 =item B<< $attr->has_documentation >>
1060
1061 Returns true if this attribute has any documentation.
1062
1063 =item B<< $attr->applied_traits >>
1064
1065 This returns an array reference of all the traits which were applied
1066 to this attribute. If none were applied, this returns C<undef>.
1067
1068 =item B<< $attr->has_applied_traits >>
1069
1070 Returns true if this attribute has any traits applied.
1071
1072 =back
1073
1074 =head1 BUGS
1075
1076 All complex software has bugs lurking in it, and this module is no
1077 exception. If you find a bug please either email me, or add the bug
1078 to cpan-RT.
1079
1080 =head1 AUTHOR
1081
1082 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1083
1084 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
1085
1086 =head1 COPYRIGHT AND LICENSE
1087
1088 Copyright 2006-2009 by Infinity Interactive, Inc.
1089
1090 L<http://www.iinteractive.com>
1091
1092 This library is free software; you can redistribute it and/or modify
1093 it under the same terms as Perl itself.
1094
1095 =cut