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', 'reftype';
   8 use Carp         'confess';
   9 use Sub::Name    'subname';
  10 use overload     ();
  11
  12 our $VERSION   = '0.18';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use Moose::Meta::Method::Accessor;
  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
  50 sub new {
  51     my ($class, $name, %options) = @_;
  52     $class->_process_options($name, \%options);
  53     return $class->SUPER::new($name, %options);
  54 }
  55
  56 sub clone_and_inherit_options {
  57     my ($self, %options) = @_;
  58     # you can change default, required, coerce, documentation and lazy
  59     my %actual_options;
  60     foreach my $legal_option (qw(default coerce required documentation lazy)) {
  61         if (exists $options{$legal_option}) {
  62             $actual_options{$legal_option} = $options{$legal_option};
  63             delete $options{$legal_option};
  64         }
  65     }
  66
  67     # handles can only be added, not changed
  68     if ($options{handles}) {
  69         confess "You can only add the 'handles' option, you cannot change it"
  70             if $self->has_handles;
  71         $actual_options{handles} = $options{handles};
  72         delete $options{handles};
  73     }
  74
  75     # isa can be changed, but only if the
  76     # new type is a subtype
  77     if ($options{isa}) {
  78         my $type_constraint;
  79         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
  80             $type_constraint = $options{isa};
  81         }
  82         else {
  83             $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint(
  84                 $options{isa}
  85             );
  86             (defined $type_constraint)
  87                 || confess "Could not find the type constraint '" . $options{isa} . "'";
  88         }
  89         # NOTE:
  90         # check here to see if the new type
  91         # is a subtype of the old one
  92         ($type_constraint->is_subtype_of($self->type_constraint->name))
  93             || confess "New type constraint setting must be a subtype of inherited one"
  94                 # iff we have a type constraint that is ...
  95                 if $self->has_type_constraint;
  96         # then we use it :)
  97         $actual_options{type_constraint} = $type_constraint;
  98         delete $options{isa};
  99     }
 100     (scalar keys %options == 0)
 101         || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
 102     $self->clone(%actual_options);
 103 }
 104
 105 sub _process_options {
 106     my ($class, $name, $options) = @_;
 107
 108     if (exists $options->{is}) {
 109         if ($options->{is} eq 'ro') {
 110             $options->{reader} ||= $name;
 111             (!exists $options->{trigger})
 112                 || confess "Cannot have a trigger on a read-only attribute";
 113         }
 114         elsif ($options->{is} eq 'rw') {
 115             $options->{accessor} = $name;
 116             ((reftype($options->{trigger}) || '') eq 'CODE')
 117                 || confess "Trigger must be a CODE ref"
 118                     if exists $options->{trigger};
 119         }
 120         else {
 121             confess "I do not understand this option (is => " . $options->{is} . ")"
 122         }
 123     }
 124
 125     if (exists $options->{isa}) {
 126         if (exists $options->{does}) {
 127             if (eval { $options->{isa}->can('does') }) {
 128                 ($options->{isa}->does($options->{does}))
 129                     || confess "Cannot have an isa option and a does option if the isa does not do the does";
 130             }
 131             else {
 132                 confess "Cannot have an isa option which cannot ->does()";
 133             }
 134         }
 135
 136         # allow for anon-subtypes here ...
 137         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 138             $options->{type_constraint} = $options->{isa};
 139         }
 140         else {
 141             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
 142                 $options->{isa} => {
 143                     parent     => Moose::Util::TypeConstraints::find_type_constraint('Object'),
 144                     constraint => sub { $_[0]->isa($options->{isa}) }
 145                 }
 146             );
 147         }
 148     }
 149     elsif (exists $options->{does}) {
 150         # allow for anon-subtypes here ...
 151         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 152                 $options->{type_constraint} = $options->{isa};
 153         }
 154         else {
 155             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
 156                 $options->{does} => {
 157                     parent     => Moose::Util::TypeConstraints::find_type_constraint('Role'),
 158                     constraint => sub { $_[0]->does($options->{does}) }
 159                 }
 160             );
 161         }
 162     }
 163
 164     if (exists $options->{coerce} && $options->{coerce}) {
 165         (exists $options->{type_constraint})
 166             || confess "You cannot have coercion without specifying a type constraint";
 167         confess "You cannot have a weak reference to a coerced value"
 168             if $options->{weak_ref};
 169     }
 170
 171     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 172         (exists $options->{type_constraint})
 173             || confess "You cannot auto-dereference without specifying a type constraint";
 174         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 175          $options->{type_constraint}->is_a_type_of('HashRef'))
 176             || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
 177     }
 178
 179     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
 180         confess("You can not use lazy_build and default for the same attribute")
 181             if exists $options->{default};
 182         $options->{lazy}      = 1;
 183         $options->{required}  = 1;
 184         $options->{builder} ||= "_build_${name}";
 185         if ($name =~ /^_/) {
 186             $options->{clearer}   ||= "_clear${name}";
 187             $options->{predicate} ||= "_has${name}";
 188         }
 189         else {
 190             $options->{clearer}   ||= "clear_${name}";
 191             $options->{predicate} ||= "has_${name}";
 192         }
 193     }
 194
 195     if (exists $options->{lazy} && $options->{lazy}) {
 196         (exists $options->{default} || exists $options->{builder} )
 197             || confess "You cannot have lazy attribute without specifying a default value for it";
 198     }
 199
 200 }
 201
 202 sub initialize_instance_slot {
 203     my ($self, $meta_instance, $instance, $params) = @_;
 204     my $init_arg = $self->init_arg();
 205     # try to fetch the init arg from the %params ...
 206
 207     my $val;
 208     my $value_is_set;
 209     if (exists $params->{$init_arg}) {
 210         $val = $params->{$init_arg};
 211         $value_is_set = 1;
 212     }
 213     else {
 214         # skip it if it's lazy
 215         return if $self->is_lazy;
 216         # and die if it's required and doesn't have a default value
 217         confess "Attribute (" . $self->name . ") is required"
 218             if $self->is_required && !$self->has_default && !$self->has_builder;
 219
 220         # if nothing was in the %params, we can use the
 221         # attribute's default value (if it has one)
 222         if ($self->has_default) {
 223             $val = $self->default($instance);
 224             $value_is_set = 1;
 225         }
 226         elsif ($self->has_builder) {
 227             if (my $builder = $instance->can($self->builder)){
 228                 $val = $instance->$builder;
 229                 $value_is_set = 1;
 230             }
 231             else {
 232                 confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
 233             }
 234         }
 235     }
 236
 237     return unless $value_is_set;
 238
 239     if ($self->has_type_constraint) {
 240         my $type_constraint = $self->type_constraint;
 241         if ($self->should_coerce && $type_constraint->has_coercion) {
 242             $val = $type_constraint->coerce($val);
 243         }
 244         (defined($type_constraint->check($val)))
 245             || confess "Attribute (" .
 246                        $self->name .
 247                        ") does not pass the type constraint (" .
 248                        $type_constraint->name .
 249                        ") with '" .
 250                        (defined $val
 251                            ? overload::StrVal($val)
 252                            : 'undef') .
 253                        "'";
 254     }
 255
 256     $meta_instance->set_slot_value($instance, $self->name, $val);
 257     $meta_instance->weaken_slot_value($instance, $self->name)
 258         if ref $val && $self->is_weak_ref;
 259 }
 260
 261 ## Slot management
 262
 263 sub set_value {
 264     my ($self, $instance, $value) = @_;
 265
 266     my $attr_name = $self->name;
 267
 268     if ($self->is_required) {
 269         defined($value)
 270             || confess "Attribute ($attr_name) is required, so cannot be set to undef";
 271     }
 272
 273     if ($self->has_type_constraint) {
 274
 275         my $type_constraint = $self->type_constraint;
 276
 277         if ($self->should_coerce) {
 278             $value = $type_constraint->coerce($value);
 279         }
 280         $type_constraint->_compiled_type_constraint->($value)
 281                 || confess "Attribute ($attr_name) does not pass the type constraint ("
 282                . $type_constraint->name
 283                . ") with "
 284                . (defined($value)
 285                     ? ("'" . overload::StrVal($value) . "'")
 286                     : "undef")
 287           if defined($value);
 288     }
 289
 290     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 291                                          ->get_meta_instance;
 292
 293     $meta_instance->set_slot_value($instance, $attr_name, $value);
 294
 295     if (ref $value && $self->is_weak_ref) {
 296         $meta_instance->weaken_slot_value($instance, $attr_name);
 297     }
 298
 299     if ($self->has_trigger) {
 300         $self->trigger->($instance, $value, $self);
 301     }
 302 }
 303
 304 sub get_value {
 305     my ($self, $instance) = @_;
 306
 307     if ($self->is_lazy) {
 308         unless ($self->has_value($instance)) {
 309             if ($self->has_default) {
 310                 my $default = $self->default($instance);
 311                 $self->set_value($instance, $default);
 312             }
 313             if ( $self->has_builder ){
 314                 if (my $builder = $instance->can($self->builder)){
 315                     $self->set_value($instance, $instance->$builder);
 316                 }
 317                 else {
 318                     confess(blessed($instance)
 319                           . " does not support builder method '"
 320                           . $self->builder
 321                           . "' for attribute '"
 322                           . $self->name
 323                           . "'");
 324                 }
 325             }
 326             else {
 327                 $self->set_value($instance, undef);
 328             }
 329         }
 330     }
 331
 332     if ($self->should_auto_deref) {
 333
 334         my $type_constraint = $self->type_constraint;
 335
 336         if ($type_constraint->is_a_type_of('ArrayRef')) {
 337             my $rv = $self->SUPER::get_value($instance);
 338             return unless defined $rv;
 339             return wantarray ? @{ $rv } : $rv;
 340         }
 341         elsif ($type_constraint->is_a_type_of('HashRef')) {
 342             my $rv = $self->SUPER::get_value($instance);
 343             return unless defined $rv;
 344             return wantarray ? %{ $rv } : $rv;
 345         }
 346         else {
 347             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 348         }
 349
 350     }
 351     else {
 352
 353         return $self->SUPER::get_value($instance);
 354     }
 355 }
 356
 357 ## installing accessors
 358
 359 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 360
 361 sub install_accessors {
 362     my $self = shift;
 363     $self->SUPER::install_accessors(@_);
 364
 365     if ($self->has_handles) {
 366
 367         # NOTE:
 368         # Here we canonicalize the 'handles' option
 369         # this will sort out any details and always
 370         # return an hash of methods which we want
 371         # to delagate to, see that method for details
 372         my %handles = $self->_canonicalize_handles();
 373
 374         # find the accessor method for this attribute
 375         my $accessor = $self->get_read_method_ref;
 376         # then unpack it if we need too ...
 377         $accessor = $accessor->body if blessed $accessor;
 378
 379         # install the delegation ...
 380         my $associated_class = $self->associated_class;
 381         foreach my $handle (keys %handles) {
 382             my $method_to_call = $handles{$handle};
 383             my $class_name = $associated_class->name;
 384             my $name = "${class_name}::${handle}";
 385
 386             (!$associated_class->has_method($handle))
 387                 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 388
 389             # NOTE:
 390             # handles is not allowed to delegate
 391             # any of these methods, as they will
 392             # override the ones in your class, which
 393             # is almost certainly not what you want.
 394
 395             # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
 396             #cluck("Not delegating method '$handle' because it is a core method") and
 397             next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 398
 399             if ((reftype($method_to_call) || '') eq 'CODE') {
 400                 $associated_class->add_method($handle => subname $name, $method_to_call);
 401             }
 402             else {
 403                 $associated_class->add_method($handle => subname $name, sub {
 404                     my $proxy = (shift)->$accessor();
 405                     @_ = ($proxy, @_);
 406                     (defined $proxy)
 407                         || confess "Cannot delegate $handle to $method_to_call because " .
 408                                    "the value of " . $self->name . " is not defined";
 409                     goto &{ $proxy->can($method_to_call) || return };
 410                 });
 411             }
 412         }
 413     }
 414
 415     return;
 416 }
 417
 418 # private methods to help delegation ...
 419
 420 sub _canonicalize_handles {
 421     my $self    = shift;
 422     my $handles = $self->handles;
 423     if (my $handle_type = ref($handles)) {
 424         if ($handle_type eq 'HASH') {
 425             return %{$handles};
 426         }
 427         elsif ($handle_type eq 'ARRAY') {
 428             return map { $_ => $_ } @{$handles};
 429         }
 430         elsif ($handle_type eq 'Regexp') {
 431             ($self->has_type_constraint)
 432                 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 433             return map  { ($_ => $_) }
 434                    grep { /$handles/ } $self->_get_delegate_method_list;
 435         }
 436         elsif ($handle_type eq 'CODE') {
 437             return $handles->($self, $self->_find_delegate_metaclass);
 438         }
 439         else {
 440             confess "Unable to canonicalize the 'handles' option with $handles";
 441         }
 442     }
 443     else {
 444         my $role_meta = eval { $handles->meta };
 445         if ($@) {
 446             confess "Unable to canonicalize the 'handles' option with $handles because : $@";
 447         }
 448
 449         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 450             || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
 451
 452         return map { $_ => $_ } (
 453             $role_meta->get_method_list,
 454             $role_meta->get_required_method_list
 455         );
 456     }
 457 }
 458
 459 sub _find_delegate_metaclass {
 460     my $self = shift;
 461     if (my $class = $self->_isa_metadata) {
 462         # if the class does have
 463         # a meta method, use it
 464         return $class->meta if $class->can('meta');
 465         # otherwise we might be
 466         # dealing with a non-Moose
 467         # class, and need to make
 468         # our own metaclass
 469         return Moose::Meta::Class->initialize($class);
 470     }
 471     elsif (my $role = $self->_does_metadata) {
 472         # our role will always have
 473         # a meta method
 474         return $role->meta;
 475     }
 476     else {
 477         confess "Cannot find delegate metaclass for attribute " . $self->name;
 478     }
 479 }
 480
 481 sub _get_delegate_method_list {
 482     my $self = shift;
 483     my $meta = $self->_find_delegate_metaclass;
 484     if ($meta->isa('Class::MOP::Class')) {
 485         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 486                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 487                     $meta->compute_all_applicable_methods;
 488     }
 489     elsif ($meta->isa('Moose::Meta::Role')) {
 490         return $meta->get_method_list;
 491     }
 492     else {
 493         confess "Unable to recognize the delegate metaclass '$meta'";
 494     }
 495 }
 496
 497 1;
 498
 499 __END__
 500
 501 =pod
 502
 503 =head1 NAME
 504
 505 Moose::Meta::Attribute - The Moose attribute metaclass
 506
 507 =head1 DESCRIPTION
 508
 509 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 510 extensions.
 511
 512 For the most part, the only time you will ever encounter an
 513 instance of this class is if you are doing some serious deep
 514 introspection. To really understand this class, you need to refer
 515 to the L<Class::MOP::Attribute> documentation.
 516
 517 =head1 METHODS
 518
 519 =head2 Overridden methods
 520
 521 These methods override methods in L<Class::MOP::Attribute> and add
 522 Moose specific features. You can safely assume though that they
 523 will behave just as L<Class::MOP::Attribute> does.
 524
 525 =over 4
 526
 527 =item B<new>
 528
 529 =item B<initialize_instance_slot>
 530
 531 =item B<install_accessors>
 532
 533 =item B<accessor_metaclass>
 534
 535 =item B<get_value>
 536
 537 =item B<set_value>
 538
 539   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 540   if($@) {
 541     print "Oops: $@\n";
 542   }
 543
 544 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 545
 546 Before setting the value, a check is made on the type constraint of
 547 the attribute, if it has one, to see if the value passes it. If the
 548 value fails to pass, the set operation dies with a L<Carp/confess>.
 549
 550 Any coercion to convert values is done before checking the type constraint.
 551
 552 To check a value against a type constraint before setting it, fetch the
 553 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 554 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 555 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
 556 for an example.
 557
 558 =back
 559
 560 =head2 Additional Moose features
 561
 562 Moose attributes support type-constraint checking, weak reference
 563 creation and type coercion.
 564
 565 =over 4
 566
 567 =item B<clone_and_inherit_options>
 568
 569 This is to support the C<has '+foo'> feature, it clones an attribute
 570 from a superclass and allows a very specific set of changes to be made
 571 to the attribute.
 572
 573 =item B<has_type_constraint>
 574
 575 Returns true if this meta-attribute has a type constraint.
 576
 577 =item B<type_constraint>
 578
 579 A read-only accessor for this meta-attribute's type constraint. For
 580 more information on what you can do with this, see the documentation
 581 for L<Moose::Meta::TypeConstraint>.
 582
 583 =item B<has_handles>
 584
 585 Returns true if this meta-attribute performs delegation.
 586
 587 =item B<handles>
 588
 589 This returns the value which was passed into the handles option.
 590
 591 =item B<is_weak_ref>
 592
 593 Returns true if this meta-attribute produces a weak reference.
 594
 595 =item B<is_required>
 596
 597 Returns true if this meta-attribute is required to have a value.
 598
 599 =item B<is_lazy>
 600
 601 Returns true if this meta-attribute should be initialized lazily.
 602
 603 NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
 604
 605 =item B<is_lazy_build>
 606
 607 Returns true if this meta-attribute should be initialized lazily through
 608 the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
 609 make your attribute required and lazy. In addition it will set the builder, clearer
 610 and predicate options for you using the following convention.
 611
 612    #If your attribute name starts with an underscore:
 613    has '_foo' => (lazy_build => 1);
 614    #is the same as
 615    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo);
 616    # or
 617    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
 618
 619    #If your attribute name does not start with an underscore:
 620    has 'foo' => (lazy_build => 1);
 621    #is the same as
 622    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo);
 623    # or
 624    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
 625
 626 The reason for the different naming of the C<builder> is that the C<builder>
 627 method is a private method while the C<clearer> and C<predicate> methods
 628 are public methods.
 629
 630 NOTE: This means your class should provide a method whose name matches the value
 631 of the builder part, in this case _build__foo or _build_foo.
 632
 633 =item B<should_coerce>
 634
 635 Returns true if this meta-attribute should perform type coercion.
 636
 637 =item B<should_auto_deref>
 638
 639 Returns true if this meta-attribute should perform automatic
 640 auto-dereferencing.
 641
 642 NOTE: This can only be done for attributes whose type constraint is
 643 either I<ArrayRef> or I<HashRef>.
 644
 645 =item B<has_trigger>
 646
 647 Returns true if this meta-attribute has a trigger set.
 648
 649 =item B<trigger>
 650
 651 This is a CODE reference which will be executed every time the
 652 value of an attribute is assigned. The CODE ref will get two values,
 653 the invocant and the new value. This can be used to handle I<basic>
 654 bi-directional relations.
 655
 656 =item B<documentation>
 657
 658 This is a string which contains the documentation for this attribute.
 659 It serves no direct purpose right now, but it might in the future
 660 in some kind of automated documentation system perhaps.
 661
 662 =item B<has_documentation>
 663
 664 Returns true if this meta-attribute has any documentation.
 665
 666 =back
 667
 668 =head1 BUGS
 669
 670 All complex software has bugs lurking in it, and this module is no
 671 exception. If you find a bug please either email me, or add the bug
 672 to cpan-RT.
 673
 674 =head1 AUTHOR
 675
 676 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 677
 678 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 679
 680 =head1 COPYRIGHT AND LICENSE
 681
 682 Copyright 2006-2008 by Infinity Interactive, Inc.
 683
 684 L<http://www.iinteractive.com>
 685
 686 This library is free software; you can redistribute it and/or modify
 687 it under the same terms as Perl itself.
 688
 689 =cut