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