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