lib/Moose/Meta/Attribute.pm

   1
   2 package Moose::Meta::Attribute;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'blessed', 'weaken';
   8 use Carp         'confess';
   9 use overload     ();
  10
  11 our $VERSION   = '0.55';
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use Moose::Meta::Method::Accessor;
  15 use Moose::Util ();
  16 use Moose::Util::TypeConstraints ();
  17
  18 use base 'Class::MOP::Attribute';
  19
  20 # options which are not directly used
  21 # but we store them for metadata purposes
  22 __PACKAGE__->meta->add_attribute('isa'  => (reader    => '_isa_metadata'));
  23 __PACKAGE__->meta->add_attribute('does' => (reader    => '_does_metadata'));
  24 __PACKAGE__->meta->add_attribute('is'   => (reader    => '_is_metadata'));
  25
  26 # these are actual options for the attrs
  27 __PACKAGE__->meta->add_attribute('required'   => (reader => 'is_required'      ));
  28 __PACKAGE__->meta->add_attribute('lazy'       => (reader => 'is_lazy'          ));
  29 __PACKAGE__->meta->add_attribute('lazy_build' => (reader => 'is_lazy_build'    ));
  30 __PACKAGE__->meta->add_attribute('coerce'     => (reader => 'should_coerce'    ));
  31 __PACKAGE__->meta->add_attribute('weak_ref'   => (reader => 'is_weak_ref'      ));
  32 __PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
  33 __PACKAGE__->meta->add_attribute('type_constraint' => (
  34     reader    => 'type_constraint',
  35     predicate => 'has_type_constraint',
  36 ));
  37 __PACKAGE__->meta->add_attribute('trigger' => (
  38     reader    => 'trigger',
  39     predicate => 'has_trigger',
  40 ));
  41 __PACKAGE__->meta->add_attribute('handles' => (
  42     reader    => 'handles',
  43     predicate => 'has_handles',
  44 ));
  45 __PACKAGE__->meta->add_attribute('documentation' => (
  46     reader    => 'documentation',
  47     predicate => 'has_documentation',
  48 ));
  49 __PACKAGE__->meta->add_attribute('traits' => (
  50     reader    => 'applied_traits',
  51     predicate => 'has_applied_traits',
  52 ));
  53
  54 # we need to have a ->does method in here to
  55 # more easily support traits, and the introspection
  56 # of those traits. We extend the does check to look
  57 # for metatrait aliases.
  58 sub does {
  59     my ($self, $role_name) = @_;
  60     my $name = eval {
  61         Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
  62     };
  63     return 0 if !defined($name); # failed to load class
  64     return Moose::Object::does($self, $name);
  65 }
  66
  67 sub new {
  68     my ($class, $name, %options) = @_;
  69     $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
  70     return $class->SUPER::new($name, %options);
  71 }
  72
  73 sub interpolate_class_and_new {
  74     my ($class, $name, @args) = @_;
  75
  76     my ( $new_class, @traits ) = $class->interpolate_class(@args);
  77
  78     $new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
  79 }
  80
  81 sub interpolate_class {
  82     my ($class, %options) = @_;
  83
  84     $class = ref($class) || $class;
  85
  86     if ( my $metaclass_name = delete $options{metaclass} ) {
  87         my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
  88
  89         if ( $class ne $new_class ) {
  90             if ( $new_class->can("interpolate_class") ) {
  91                 return $new_class->interpolate_class(%options);
  92             } else {
  93                 $class = $new_class;
  94             }
  95         }
  96     }
  97
  98     my @traits;
  99
 100     if (my $traits = $options{traits}) {
 101         if ( @traits = grep { not $class->does($_) } map {
 102             Moose::Util::resolve_metatrait_alias( Attribute => $_ )
 103                 or
 104             $_
 105         } @$traits ) {
 106             my $anon_class = Moose::Meta::Class->create_anon_class(
 107                 superclasses => [ $class ],
 108                 roles        => [ @traits ],
 109                 cache        => 1,
 110             );
 111
 112             $class = $anon_class->name;
 113         }
 114     }
 115
 116     return ( wantarray ? ( $class, @traits ) : $class );
 117 }
 118
 119 # ...
 120
 121 my @legal_options_for_inheritance = qw(
 122     default coerce required
 123     documentation lazy handles
 124     builder type_constraint
 125 );
 126
 127 sub legal_options_for_inheritance { @legal_options_for_inheritance }
 128
 129 # NOTE/TODO
 130 # This method *must* be able to handle
 131 # Class::MOP::Attribute instances as
 132 # well. Yes, I know that is wrong, but
 133 # apparently we didn't realize it was
 134 # doing that and now we have some code
 135 # which is dependent on it. The real
 136 # solution of course is to push this
 137 # feature back up into Class::MOP::Attribute
 138 # but I not right now, I am too lazy.
 139 # However if you are reading this and
 140 # looking for something to do,.. please
 141 # be my guest.
 142 # - stevan
 143 sub clone_and_inherit_options {
 144     my ($self, %options) = @_;
 145
 146     my %copy = %options;
 147
 148     my %actual_options;
 149
 150     # NOTE:
 151     # we may want to extends a Class::MOP::Attribute
 152     # in which case we need to be able to use the
 153     # core set of legal options that have always
 154     # been here. But we allows Moose::Meta::Attribute
 155     # instances to changes them.
 156     # - SL
 157     my @legal_options = $self->can('legal_options_for_inheritance')
 158         ? $self->legal_options_for_inheritance
 159         : @legal_options_for_inheritance;
 160
 161     foreach my $legal_option (@legal_options) {
 162         if (exists $options{$legal_option}) {
 163             $actual_options{$legal_option} = $options{$legal_option};
 164             delete $options{$legal_option};
 165         }
 166     }
 167
 168     if ($options{isa}) {
 169         my $type_constraint;
 170         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
 171             $type_constraint = $options{isa};
 172         }
 173         else {
 174             $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
 175             (defined $type_constraint)
 176                 || confess "Could not find the type constraint '" . $options{isa} . "'";
 177         }
 178
 179         $actual_options{type_constraint} = $type_constraint;
 180         delete $options{isa};
 181     }
 182
 183     if ($options{does}) {
 184         my $type_constraint;
 185         if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
 186             $type_constraint = $options{does};
 187         }
 188         else {
 189             $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
 190             (defined $type_constraint)
 191                 || confess "Could not find the type constraint '" . $options{does} . "'";
 192         }
 193
 194         $actual_options{type_constraint} = $type_constraint;
 195         delete $options{does};
 196     }
 197
 198     # NOTE:
 199     # this doesn't apply to Class::MOP::Attributes,
 200     # so we can ignore it for them.
 201     # - SL
 202     if ($self->can('interpolate_class')) {
 203         ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(%options);
 204
 205         my %seen;
 206         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
 207         $actual_options{traits} = \@all_traits if @all_traits;
 208
 209         delete @options{qw(metaclass traits)};
 210     }
 211
 212     (scalar keys %options == 0)
 213         || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
 214
 215
 216     $self->clone(%actual_options);
 217 }
 218
 219 sub clone {
 220     my ( $self, %params ) = @_;
 221
 222     my $class = $params{metaclass} || ref $self;
 223
 224     if ( 0 and $class eq ref $self ) {
 225         return $self->SUPER::clone(%params);
 226     } else {
 227         my ( @init, @non_init );
 228
 229         foreach my $attr ( grep { $_->has_value($self) } $self->meta->compute_all_applicable_attributes ) {
 230             push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
 231         }
 232
 233         my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
 234
 235         my $name = delete $new_params{name};
 236
 237         my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
 238
 239         foreach my $attr ( @non_init ) {
 240             $attr->set_value($clone, $attr->get_value($self));
 241         }
 242
 243
 244         return $clone;
 245     }
 246 }
 247
 248 sub _process_options {
 249     my ($class, $name, $options) = @_;
 250
 251     if (exists $options->{is}) {
 252
 253         ### -------------------------
 254         ## is => ro, writer => _foo    # turns into (reader => foo, writer => _foo) as before
 255         ## is => rw, writer => _foo    # turns into (reader => foo, writer => _foo)
 256         ## is => rw, accessor => _foo  # turns into (accessor => _foo)
 257         ## is => ro, accessor => _foo  # error, accesor is rw
 258         ### -------------------------
 259
 260         if ($options->{is} eq 'ro') {
 261             confess "Cannot define an accessor name on a read-only attribute, accessors are read/write"
 262                 if exists $options->{accessor};
 263             $options->{reader} ||= $name;
 264         }
 265         elsif ($options->{is} eq 'rw') {
 266             if ($options->{writer}) {
 267                 $options->{reader} ||= $name;
 268             }
 269             else {
 270                 $options->{accessor} ||= $name;
 271             }
 272         }
 273         else {
 274             confess "I do not understand this option (is => " . $options->{is} . ") on attribute ($name)"
 275         }
 276     }
 277
 278     if (exists $options->{isa}) {
 279         if (exists $options->{does}) {
 280             if (eval { $options->{isa}->can('does') }) {
 281                 ($options->{isa}->does($options->{does}))
 282                     || confess "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)";
 283             }
 284             else {
 285                 confess "Cannot have an isa option which cannot ->does() on attribute ($name)";
 286             }
 287         }
 288
 289         # allow for anon-subtypes here ...
 290         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 291             $options->{type_constraint} = $options->{isa};
 292         }
 293         else {
 294             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa});
 295         }
 296     }
 297     elsif (exists $options->{does}) {
 298         # allow for anon-subtypes here ...
 299         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 300                 $options->{type_constraint} = $options->{does};
 301         }
 302         else {
 303             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does});
 304         }
 305     }
 306
 307     if (exists $options->{coerce} && $options->{coerce}) {
 308         (exists $options->{type_constraint})
 309             || confess "You cannot have coercion without specifying a type constraint on attribute ($name)";
 310         confess "You cannot have a weak reference to a coerced value on attribute ($name)"
 311             if $options->{weak_ref};
 312     }
 313
 314     if (exists $options->{trigger}) {
 315         my $trig = $options->{trigger};
 316         if ('HASH' eq ref $trig) {
 317             my $legal = qr{^(?:before|after|around)$};
 318             foreach my $key (keys %$trig) {
 319                 ($key =~ $legal)
 320                     || confess "$key is an illegal trigger specifier"
 321                     . " on attribute ($name)";
 322                 ('CODE' eq ref $trig->{$key})
 323                     || confess "$key trigger must be CODE ref"
 324                     . " on attribute ($name)";
 325             }
 326         }
 327         elsif ('CODE' ne ref $trig) {
 328             confess "Trigger must be a CODE or HASH ref on attribute ($name)";
 329         }
 330     }
 331
 332     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 333         (exists $options->{type_constraint})
 334             || confess "You cannot auto-dereference without specifying a type constraint on attribute ($name)";
 335         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 336          $options->{type_constraint}->is_a_type_of('HashRef'))
 337             || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)";
 338     }
 339
 340     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
 341         confess("You can not use lazy_build and default for the same attribute ($name)")
 342             if exists $options->{default};
 343         $options->{lazy}      = 1;
 344         $options->{required}  = 1;
 345         $options->{builder} ||= "_build_${name}";
 346         if ($name =~ /^_/) {
 347             $options->{clearer}   ||= "_clear${name}";
 348             $options->{predicate} ||= "_has${name}";
 349         }
 350         else {
 351             $options->{clearer}   ||= "clear_${name}";
 352             $options->{predicate} ||= "has_${name}";
 353         }
 354     }
 355
 356     if (exists $options->{lazy} && $options->{lazy}) {
 357         (exists $options->{default} || defined $options->{builder} )
 358             || confess "You cannot have lazy attribute ($name) without specifying a default value for it";
 359     }
 360
 361     if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) {
 362         confess "You cannot have a required attribute ($name) without a default, builder, or an init_arg";
 363     }
 364
 365 }
 366
 367 sub _with_inline_triggers {
 368     my ($self, $instance, $value, $attr, $gen_code) = @_;
 369     my @ga = ($instance, $value, $attr);
 370     return $gen_code->(@ga) unless $self->has_trigger;
 371
 372     my $trigger_args = "$instance, $value, $attr";
 373
 374     if ('CODE' eq ref $self->trigger) {
 375         return $gen_code->(@ga) . "$attr->trigger->($trigger_args);\n";
 376     }
 377
 378     my $code = '';
 379     my ($before, $around, $after) = @{$self->trigger}{qw(before around after)};
 380
 381     if ($before) {
 382         $code .= "$attr->trigger->{before}->($trigger_args);\n";
 383     }
 384
 385     if ($around) {
 386         $code .= "$attr->trigger->{around}->(sub {\n"
 387             . 'my ($instance, $value, $attr) = @_;' . "\n"
 388             . $gen_code->('$instance', '$value', '$attr')
 389             . "}, $trigger_args);\n";
 390     }
 391     else {
 392         $code .= $gen_code->(@ga);
 393     }
 394
 395     if ($after) {
 396         $code .= "$attr->trigger->{after}->($trigger_args);\n";
 397     }
 398
 399     return $code;
 400 }
 401
 402 sub _with_triggers {
 403     my ($self, $instance, $value, $fn) = @_;
 404     my @trigger_args = ($instance, $value, $self);
 405     my ($before, $around, $after);
 406
 407     if ($self->has_trigger) {
 408         my $trig = $self->trigger;
 409
 410         if ('HASH' eq ref $trig) {
 411             ($before, $around, $after) = @{$trig}{qw(before around after)}
 412         }
 413         else {
 414             $after = $trig;
 415         }
 416     }
 417
 418     if ($before) {
 419         $before->(@trigger_args);
 420     }
 421
 422     if ($around) {
 423         $around->($fn, @trigger_args);
 424     }
 425     else {
 426         $fn->(@trigger_args);
 427     }
 428
 429     if ($after) {
 430         $after->(@trigger_args);
 431     }
 432 }
 433
 434 sub initialize_instance_slot {
 435     my ($self, $meta_instance, $instance, $params) = @_;
 436     my $init_arg = $self->init_arg();
 437     # try to fetch the init arg from the %params ...
 438
 439     my $val;
 440     my $value_is_set;
 441     if ( defined($init_arg) and exists $params->{$init_arg}) {
 442         $val = $params->{$init_arg};
 443         $value_is_set = 1;
 444     }
 445     else {
 446         # skip it if it's lazy
 447         return if $self->is_lazy;
 448         # and die if it's required and doesn't have a default value
 449         confess "Attribute (" . $self->name . ") is required"
 450             if $self->is_required && !$self->has_default && !$self->has_builder;
 451
 452         # if nothing was in the %params, we can use the
 453         # attribute's default value (if it has one)
 454         if ($self->has_default) {
 455             $val = $self->default($instance);
 456             $value_is_set = 1;
 457         }
 458         elsif ($self->has_builder) {
 459             if (my $builder = $instance->can($self->builder)){
 460                 $val = $instance->$builder;
 461                 $value_is_set = 1;
 462             }
 463             else {
 464                 confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
 465             }
 466         }
 467     }
 468
 469     return unless $value_is_set;
 470
 471     if ($self->has_type_constraint) {
 472         my $type_constraint = $self->type_constraint;
 473         if ($self->should_coerce && $type_constraint->has_coercion) {
 474             $val = $type_constraint->coerce($val);
 475         }
 476         $type_constraint->check($val)
 477             || confess "Attribute ("
 478                      . $self->name
 479                      . ") does not pass the type constraint because: "
 480                      . $type_constraint->get_message($val);
 481     }
 482
 483     $self->_with_triggers($instance, $val, sub {
 484         my ($ins, $val, $attr) = @_;
 485         my $mi = Class::MOP::Class->initialize(blessed($ins))
 486                                   ->get_meta_instance;
 487         $attr->set_initial_value($ins, $val);
 488         $mi->weaken_slot_value($ins, $attr->name)
 489             if ref $val && $attr->is_weak_ref;
 490     });
 491 }
 492
 493 ## Slot management
 494
 495 # FIXME:
 496 # this duplicates too much code from
 497 # Class::MOP::Attribute, we need to
 498 # refactor these bits eventually.
 499 # - SL
 500 sub _set_initial_slot_value {
 501     my ($self, $meta_instance, $instance, $value) = @_;
 502
 503     my $slot_name = $self->name;
 504
 505     return $meta_instance->set_slot_value($instance, $slot_name, $value)
 506         unless $self->has_initializer;
 507
 508     my ($type_constraint, $can_coerce);
 509     if ($self->has_type_constraint) {
 510         $type_constraint = $self->type_constraint;
 511         $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
 512     }
 513
 514     my $callback = sub {
 515         my $val = shift;
 516         if ($type_constraint) {
 517             $val = $type_constraint->coerce($val)
 518                 if $can_coerce;
 519             $type_constraint->check($val)
 520                 || confess "Attribute ("
 521                          . $slot_name
 522                          . ") does not pass the type constraint because: "
 523                          . $type_constraint->get_message($val);
 524         }
 525         $meta_instance->set_slot_value($instance, $slot_name, $val);
 526     };
 527
 528     my $initializer = $self->initializer;
 529
 530     # most things will just want to set a value, so make it first arg
 531     $instance->$initializer($value, $callback, $self);
 532 }
 533
 534 sub set_value {
 535     my ($self, $instance, @args) = @_;
 536     my $value = $args[0];
 537
 538     my $attr_name = $self->name;
 539
 540     if ($self->is_required and not @args) {
 541         confess "Attribute ($attr_name) is required";
 542     }
 543
 544     if ($self->has_type_constraint) {
 545
 546         my $type_constraint = $self->type_constraint;
 547
 548         if ($self->should_coerce) {
 549             $value = $type_constraint->coerce($value);
 550         }
 551         $type_constraint->_compiled_type_constraint->($value)
 552             || confess "Attribute ("
 553                      . $self->name
 554                      . ") does not pass the type constraint because "
 555                      . $type_constraint->get_message($value);
 556     }
 557
 558     $self->_with_triggers($instance, $value, sub {
 559         my ($ins, $val, $attr) = @_;
 560         my $mi = Class::MOP::Class->initialize(blessed($ins))
 561                                   ->get_meta_instance;
 562         $mi->set_slot_value($ins, $attr->name, $val);
 563         $mi->weaken_slot_value($ins, $attr->name)
 564             if (ref $val && $attr->is_weak_ref);
 565     });
 566 }
 567
 568 sub get_value {
 569     my ($self, $instance) = @_;
 570
 571     if ($self->is_lazy) {
 572         unless ($self->has_value($instance)) {
 573             if ($self->has_default) {
 574                 my $default = $self->default($instance);
 575                 $self->set_initial_value($instance, $default);
 576             } elsif ( $self->has_builder ) {
 577                 if (my $builder = $instance->can($self->builder)){
 578                     $self->set_initial_value($instance, $instance->$builder);
 579                 }
 580                 else {
 581                     confess(blessed($instance)
 582                           . " does not support builder method '"
 583                           . $self->builder
 584                           . "' for attribute '"
 585                           . $self->name
 586                           . "'");
 587                 }
 588             }
 589             else {
 590                 $self->set_initial_value($instance, undef);
 591             }
 592         }
 593     }
 594
 595     if ($self->should_auto_deref) {
 596
 597         my $type_constraint = $self->type_constraint;
 598
 599         if ($type_constraint->is_a_type_of('ArrayRef')) {
 600             my $rv = $self->SUPER::get_value($instance);
 601             return unless defined $rv;
 602             return wantarray ? @{ $rv } : $rv;
 603         }
 604         elsif ($type_constraint->is_a_type_of('HashRef')) {
 605             my $rv = $self->SUPER::get_value($instance);
 606             return unless defined $rv;
 607             return wantarray ? %{ $rv } : $rv;
 608         }
 609         else {
 610             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 611         }
 612
 613     }
 614     else {
 615
 616         return $self->SUPER::get_value($instance);
 617     }
 618 }
 619
 620 ## installing accessors
 621
 622 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 623
 624 sub install_accessors {
 625     my $self = shift;
 626     $self->SUPER::install_accessors(@_);
 627     $self->install_delegation if $self->has_handles;
 628     return;
 629 }
 630
 631 sub install_delegation {
 632     my $self = shift;
 633
 634     # NOTE:
 635     # Here we canonicalize the 'handles' option
 636     # this will sort out any details and always
 637     # return an hash of methods which we want
 638     # to delagate to, see that method for details
 639     my %handles = $self->_canonicalize_handles;
 640
 641     # find the accessor method for this attribute
 642     my $accessor = $self->_get_delegate_accessor;
 643
 644     # install the delegation ...
 645     my $associated_class = $self->associated_class;
 646     foreach my $handle (keys %handles) {
 647         my $method_to_call = $handles{$handle};
 648         my $class_name = $associated_class->name;
 649         my $name = "${class_name}::${handle}";
 650
 651         (!$associated_class->has_method($handle))
 652             || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 653
 654         # NOTE:
 655         # handles is not allowed to delegate
 656         # any of these methods, as they will
 657         # override the ones in your class, which
 658         # is almost certainly not what you want.
 659
 660         # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 661         #cluck("Not delegating method '$handle' because it is a core method") and
 662         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 663
 664         if ('CODE' eq ref($method_to_call)) {
 665             $associated_class->add_method($handle => Class::MOP::subname($name, $method_to_call));
 666         }
 667         else {
 668             # NOTE:
 669             # we used to do a goto here, but the
 670             # goto didn't handle failure correctly
 671             # (it just returned nothing), so I took
 672             # that out. However, the more I thought
 673             # about it, the less I liked it doing
 674             # the goto, and I prefered the act of
 675             # delegation being actually represented
 676             # in the stack trace.
 677             # - SL
 678             $associated_class->add_method($handle => Class::MOP::subname($name, sub {
 679                 my $proxy = (shift)->$accessor();
 680                 (defined $proxy)
 681                     || confess "Cannot delegate $handle to $method_to_call because " .
 682                                "the value of " . $self->name . " is not defined";
 683                 $proxy->$method_to_call(@_);
 684             }));
 685         }
 686     }
 687 }
 688
 689 # private methods to help delegation ...
 690
 691 sub _get_delegate_accessor {
 692     my $self = shift;
 693     # find the accessor method for this attribute
 694     my $accessor = $self->get_read_method_ref;
 695     # then unpack it if we need too ...
 696     $accessor = $accessor->body if blessed $accessor;
 697     # return the accessor
 698     return $accessor;
 699 }
 700
 701 sub _canonicalize_handles {
 702     my $self    = shift;
 703     my $handles = $self->handles;
 704     if (my $handle_type = ref($handles)) {
 705         if ($handle_type eq 'HASH') {
 706             return %{$handles};
 707         }
 708         elsif ($handle_type eq 'ARRAY') {
 709             return map { $_ => $_ } @{$handles};
 710         }
 711         elsif ($handle_type eq 'Regexp') {
 712             ($self->has_type_constraint)
 713                 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 714             return map  { ($_ => $_) }
 715                    grep { /$handles/ } $self->_get_delegate_method_list;
 716         }
 717         elsif ($handle_type eq 'CODE') {
 718             return $handles->($self, $self->_find_delegate_metaclass);
 719         }
 720         else {
 721             confess "Unable to canonicalize the 'handles' option with $handles";
 722         }
 723     }
 724     else {
 725         my $role_meta = eval { $handles->meta };
 726         if ($@) {
 727             confess "Unable to canonicalize the 'handles' option with $handles because : $@";
 728         }
 729
 730         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 731             || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
 732
 733         return map { $_ => $_ } (
 734             $role_meta->get_method_list,
 735             $role_meta->get_required_method_list
 736         );
 737     }
 738 }
 739
 740 sub _find_delegate_metaclass {
 741     my $self = shift;
 742     if (my $class = $self->_isa_metadata) {
 743         # if the class does have
 744         # a meta method, use it
 745         return $class->meta if $class->can('meta');
 746         # otherwise we might be
 747         # dealing with a non-Moose
 748         # class, and need to make
 749         # our own metaclass
 750         return Moose::Meta::Class->initialize($class);
 751     }
 752     elsif (my $role = $self->_does_metadata) {
 753         # our role will always have
 754         # a meta method
 755         return $role->meta;
 756     }
 757     else {
 758         confess "Cannot find delegate metaclass for attribute " . $self->name;
 759     }
 760 }
 761
 762 sub _get_delegate_method_list {
 763     my $self = shift;
 764     my $meta = $self->_find_delegate_metaclass;
 765     if ($meta->isa('Class::MOP::Class')) {
 766         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 767                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 768                     $meta->compute_all_applicable_methods;
 769     }
 770     elsif ($meta->isa('Moose::Meta::Role')) {
 771         return $meta->get_method_list;
 772     }
 773     else {
 774         confess "Unable to recognize the delegate metaclass '$meta'";
 775     }
 776 }
 777
 778 package Moose::Meta::Attribute::Custom::Moose;
 779 sub register_implementation { 'Moose::Meta::Attribute' }
 780
 781 1;
 782
 783 __END__
 784
 785 =pod
 786
 787 =head1 NAME
 788
 789 Moose::Meta::Attribute - The Moose attribute metaclass
 790
 791 =head1 DESCRIPTION
 792
 793 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 794 extensions.
 795
 796 For the most part, the only time you will ever encounter an
 797 instance of this class is if you are doing some serious deep
 798 introspection. To really understand this class, you need to refer
 799 to the L<Class::MOP::Attribute> documentation.
 800
 801 =head1 METHODS
 802
 803 =head2 Overridden methods
 804
 805 These methods override methods in L<Class::MOP::Attribute> and add
 806 Moose specific features. You can safely assume though that they
 807 will behave just as L<Class::MOP::Attribute> does.
 808
 809 =over 4
 810
 811 =item B<new>
 812
 813 =item B<clone>
 814
 815 =item B<does>
 816
 817 =item B<initialize_instance_slot>
 818
 819 =item B<install_accessors>
 820
 821 =item B<install_delegation>
 822
 823 =item B<accessor_metaclass>
 824
 825 =item B<get_value>
 826
 827 =item B<set_value>
 828
 829   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 830   if($@) {
 831     print "Oops: $@\n";
 832   }
 833
 834 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 835
 836 Before setting the value, a check is made on the type constraint of
 837 the attribute, if it has one, to see if the value passes it. If the
 838 value fails to pass, the set operation dies with a L<Carp/confess>.
 839
 840 Any coercion to convert values is done before checking the type constraint.
 841
 842 To check a value against a type constraint before setting it, fetch the
 843 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 844 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 845 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
 846 for an example.
 847
 848 =back
 849
 850 =head2 Additional Moose features
 851
 852 Moose attributes support type-constraint checking, weak reference
 853 creation and type coercion.
 854
 855 =over 4
 856
 857 =item B<interpolate_class_and_new>
 858
 859 =item B<interpolate_class>
 860
 861 When called as a class method causes interpretation of the C<metaclass> and
 862 C<traits> options.
 863
 864 =item B<clone_and_inherit_options>
 865
 866 This is to support the C<has '+foo'> feature, it clones an attribute
 867 from a superclass and allows a very specific set of changes to be made
 868 to the attribute.
 869
 870 =item B<legal_options_for_inheritance>
 871
 872 Whitelist with options you can change. You can overload it in your custom
 873 metaclass to allow your options be inheritable.
 874
 875 =item B<has_type_constraint>
 876
 877 Returns true if this meta-attribute has a type constraint.
 878
 879 =item B<type_constraint>
 880
 881 A read-only accessor for this meta-attribute's type constraint. For
 882 more information on what you can do with this, see the documentation
 883 for L<Moose::Meta::TypeConstraint>.
 884
 885 =item B<has_handles>
 886
 887 Returns true if this meta-attribute performs delegation.
 888
 889 =item B<handles>
 890
 891 This returns the value which was passed into the handles option.
 892
 893 =item B<is_weak_ref>
 894
 895 Returns true if this meta-attribute produces a weak reference.
 896
 897 =item B<is_required>
 898
 899 Returns true if this meta-attribute is required to have a value.
 900
 901 =item B<is_lazy>
 902
 903 Returns true if this meta-attribute should be initialized lazily.
 904
 905 NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
 906
 907 =item B<is_lazy_build>
 908
 909 Returns true if this meta-attribute should be initialized lazily through
 910 the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
 911 make your attribute required and lazy. In addition it will set the builder, clearer
 912 and predicate options for you using the following convention.
 913
 914    #If your attribute name starts with an underscore:
 915    has '_foo' => (lazy_build => 1);
 916    #is the same as
 917    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo);
 918    # or
 919    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
 920
 921    #If your attribute name does not start with an underscore:
 922    has 'foo' => (lazy_build => 1);
 923    #is the same as
 924    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo);
 925    # or
 926    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
 927
 928 The reason for the different naming of the C<builder> is that the C<builder>
 929 method is a private method while the C<clearer> and C<predicate> methods
 930 are public methods.
 931
 932 NOTE: This means your class should provide a method whose name matches the value
 933 of the builder part, in this case _build__foo or _build_foo.
 934
 935 =item B<should_coerce>
 936
 937 Returns true if this meta-attribute should perform type coercion.
 938
 939 =item B<should_auto_deref>
 940
 941 Returns true if this meta-attribute should perform automatic
 942 auto-dereferencing.
 943
 944 NOTE: This can only be done for attributes whose type constraint is
 945 either I<ArrayRef> or I<HashRef>.
 946
 947 =item B<has_trigger>
 948
 949 Returns true if this meta-attribute has a trigger set.
 950
 951 =item B<trigger>
 952
 953 This is a CODE reference which will be executed every time the
 954 value of an attribute is assigned. The CODE ref will get two values,
 955 the invocant and the new value. This can be used to handle I<basic>
 956 bi-directional relations.
 957
 958 =item B<documentation>
 959
 960 This is a string which contains the documentation for this attribute.
 961 It serves no direct purpose right now, but it might in the future
 962 in some kind of automated documentation system perhaps.
 963
 964 =item B<has_documentation>
 965
 966 Returns true if this meta-attribute has any documentation.
 967
 968 =item B<applied_traits>
 969
 970 This will return the ARRAY ref of all the traits applied to this
 971 attribute, or if no traits have been applied, it returns C<undef>.
 972
 973 =item B<has_applied_traits>
 974
 975 Returns true if this meta-attribute has any traits applied.
 976
 977 =back
 978
 979 =head1 BUGS
 980
 981 All complex software has bugs lurking in it, and this module is no
 982 exception. If you find a bug please either email me, or add the bug
 983 to cpan-RT.
 984
 985 =head1 AUTHOR
 986
 987 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 988
 989 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 990
 991 =head1 COPYRIGHT AND LICENSE
 992
 993 Copyright 2006-2008 by Infinity Interactive, Inc.
 994
 995 L<http://www.iinteractive.com>
 996
 997 This library is free software; you can redistribute it and/or modify
 998 it under the same terms as Perl itself.
 999
1000 =cut