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             if($name =~ /^_/){
 183                 $options->{builder}   ||= "_build${name}";
 184                 $options->{clearer}   ||= "_clear${name}";
 185                 $options->{predicate} ||= "_has${name}";
 186             } else {
 187                 $options->{builder}   ||= "build_${name}";
 188                 $options->{clearer}   ||= "clear_${name}";
 189                 $options->{predicate} ||= "has_${name}";
 190             }
 191         }
 192
 193         if (exists $options->{lazy} && $options->{lazy}) {
 194             (exists $options->{default} || exists $options->{builder} )
 195                 || confess "You cannot have lazy attribute without specifying a default value for it";
 196         }
 197
 198 }
 199
 200 sub initialize_instance_slot {
 201     my ($self, $meta_instance, $instance, $params) = @_;
 202     my $init_arg = $self->init_arg();
 203     # try to fetch the init arg from the %params ...
 204
 205     my $val;
 206     if (exists $params->{$init_arg}) {
 207         $val = $params->{$init_arg};
 208
 209         if (!defined $val && $self->is_required) {
 210             confess "Attribute (" . $self->name . ") is required and cannot be undef";
 211         }
 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
 221     # if nothing was in the %params, we can use the
 222     # attribute's default value (if it has one)
 223     if (!defined $val && $self->has_default) {
 224         $val = $self->default($instance);
 225     } elsif (!defined $val && $self->has_builder) {
 226         my $builder = $self->builder;
 227         if($builder = $instance->can($builder)){
 228             $val = $instance->$builder;
 229         } else {
 230             confess(blessed($instance)." does not support builder method '$builder' for attribute '" . $self->name . "'");
 231         }
 232     }
 233
 234         if (defined $val || $self->has_default) {
 235             if ($self->has_type_constraint) {
 236                 my $type_constraint = $self->type_constraint;
 237                     if ($self->should_coerce && $type_constraint->has_coercion) {
 238                         $val = $type_constraint->coerce($val);
 239                     }
 240             (defined($type_constraint->check($val)))
 241                 || confess "Attribute (" .
 242                            $self->name .
 243                            ") does not pass the type constraint (" .
 244                            $type_constraint->name .
 245                            ") with '" .
 246                            (defined $val
 247                                ? (blessed($val) && overload::Overloaded($val)
 248                                     ? overload::StrVal($val)
 249                                     : $val)
 250                                : 'undef') .
 251                            "'";
 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                     my $builder = $self->builder;
 318                     if($builder = $instance->can($builder)){
 319                         $self->set_value($instance, $instance->$builder);
 320                     } else {
 321                         confess(blessed($instance)." does not support builder method '$builder' for attribute '" . $self->name . "'");
 322                     }
 323                 } else {
 324                     $self->set_value($instance, undef);
 325                 }
 326             }
 327     }
 328
 329     if ($self->should_auto_deref) {
 330
 331         my $type_constraint = $self->type_constraint;
 332
 333         if ($type_constraint->is_a_type_of('ArrayRef')) {
 334             my $rv = $self->SUPER::get_value($instance);
 335             return unless defined $rv;
 336             return wantarray ? @{ $rv } : $rv;
 337         }
 338         elsif ($type_constraint->is_a_type_of('HashRef')) {
 339             my $rv = $self->SUPER::get_value($instance);
 340             return unless defined $rv;
 341             return wantarray ? %{ $rv } : $rv;
 342         }
 343         else {
 344             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 345         }
 346
 347     }
 348     else {
 349
 350         return $self->SUPER::get_value($instance);
 351     }
 352 }
 353
 354 ## installing accessors
 355
 356 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 357
 358 sub install_accessors {
 359     my $self = shift;
 360     $self->SUPER::install_accessors(@_);
 361
 362     if ($self->has_handles) {
 363
 364         # NOTE:
 365         # Here we canonicalize the 'handles' option
 366         # this will sort out any details and always
 367         # return an hash of methods which we want
 368         # to delagate to, see that method for details
 369         my %handles = $self->_canonicalize_handles();
 370
 371         # find the name of the accessor for this attribute
 372         my $accessor_name = $self->reader || $self->accessor;
 373         (defined $accessor_name)
 374             || confess "You cannot install delegation without a reader or accessor for the attribute";
 375
 376         # make sure we handle HASH accessors correctly
 377         ($accessor_name) = keys %{$accessor_name}
 378             if ref($accessor_name) eq 'HASH';
 379
 380         # install the delegation ...
 381         my $associated_class = $self->associated_class;
 382         foreach my $handle (keys %handles) {
 383             my $method_to_call = $handles{$handle};
 384
 385             (!$associated_class->has_method($handle))
 386                 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 387
 388             # NOTE:
 389             # handles is not allowed to delegate
 390             # any of these methods, as they will
 391             # override the ones in your class, which
 392             # is almost certainly not what you want.
 393             next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 394
 395             if ((reftype($method_to_call) || '') eq 'CODE') {
 396                 $associated_class->add_method($handle => $method_to_call);
 397             }
 398             else {
 399                 $associated_class->add_method($handle => sub {
 400                     # FIXME
 401                     # we should check for lack of
 402                     # a callable return value from
 403                     # the accessor here
 404                     my $proxy = (shift)->$accessor_name();
 405                     @_ = ($proxy, @_);
 406                     goto &{ $proxy->can($method_to_call)};
 407                 });
 408             }
 409         }
 410     }
 411
 412     return;
 413 }
 414
 415 # private methods to help delegation ...
 416
 417 sub _canonicalize_handles {
 418     my $self    = shift;
 419     my $handles = $self->handles;
 420     if (my $handle_type = ref($handles)) {
 421         if ($handle_type eq 'HASH') {
 422             return %{$handles};
 423         }
 424         elsif ($handle_type eq 'ARRAY') {
 425             return map { $_ => $_ } @{$handles};
 426         }
 427         elsif ($handle_type eq 'Regexp') {
 428             ($self->has_type_constraint)
 429                 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 430             return map  { ($_ => $_) }
 431                    grep { /$handles/ } $self->_get_delegate_method_list;
 432         }
 433         elsif ($handle_type eq 'CODE') {
 434             return $handles->($self, $self->_find_delegate_metaclass);
 435         }
 436         else {
 437             confess "Unable to canonicalize the 'handles' option with $handles";
 438         }
 439     }
 440     else {
 441         my $role_meta = eval { $handles->meta };
 442         if ($@) {
 443             confess "Unable to canonicalize the 'handles' option with $handles because : $@";
 444         }
 445
 446         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 447             || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
 448
 449         return map { $_ => $_ } (
 450             $role_meta->get_method_list,
 451             $role_meta->get_required_method_list
 452         );
 453     }
 454 }
 455
 456 sub _find_delegate_metaclass {
 457     my $self = shift;
 458     if (my $class = $self->_isa_metadata) {
 459         # if the class does have
 460         # a meta method, use it
 461         return $class->meta if $class->can('meta');
 462         # otherwise we might be
 463         # dealing with a non-Moose
 464         # class, and need to make
 465         # our own metaclass
 466         return Moose::Meta::Class->initialize($class);
 467     }
 468     elsif (my $role = $self->_does_metadata) {
 469         # our role will always have
 470         # a meta method
 471         return $role->meta;
 472     }
 473     else {
 474         confess "Cannot find delegate metaclass for attribute " . $self->name;
 475     }
 476 }
 477
 478 sub _get_delegate_method_list {
 479     my $self = shift;
 480     my $meta = $self->_find_delegate_metaclass;
 481     if ($meta->isa('Class::MOP::Class')) {
 482         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 483                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 484                     $meta->compute_all_applicable_methods;
 485     }
 486     elsif ($meta->isa('Moose::Meta::Role')) {
 487         return $meta->get_method_list;
 488     }
 489     else {
 490         confess "Unable to recognize the delegate metaclass '$meta'";
 491     }
 492 }
 493
 494 1;
 495
 496 __END__
 497
 498 =pod
 499
 500 =head1 NAME
 501
 502 Moose::Meta::Attribute - The Moose attribute metaclass
 503
 504 =head1 DESCRIPTION
 505
 506 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 507 extensions.
 508
 509 For the most part, the only time you will ever encounter an
 510 instance of this class is if you are doing some serious deep
 511 introspection. To really understand this class, you need to refer
 512 to the L<Class::MOP::Attribute> documentation.
 513
 514 =head1 METHODS
 515
 516 =head2 Overridden methods
 517
 518 These methods override methods in L<Class::MOP::Attribute> and add
 519 Moose specific features. You can safely assume though that they
 520 will behave just as L<Class::MOP::Attribute> does.
 521
 522 =over 4
 523
 524 =item B<new>
 525
 526 =item B<initialize_instance_slot>
 527
 528 =item B<install_accessors>
 529
 530 =item B<accessor_metaclass>
 531
 532 =item B<get_value>
 533
 534 =item B<set_value>
 535
 536   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 537   if($@) {
 538     print "Oops: $@\n";
 539   }
 540
 541 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 542
 543 Before setting the value, a check is made on the type constraint of
 544 the attribute, if it has one, to see if the value passes it. If the
 545 value fails to pass, the set operation dies with a L<Carp/confess>.
 546
 547 Any coercion to convert values is done before checking the type constraint.
 548
 549 To check a value against a type constraint before setting it, fetch the
 550 attribute instance using L<Moose::Meta::Attribute/find_attribute_by_name>,
 551 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 552 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
 553 for an example.
 554
 555 =back
 556
 557 =head2 Additional Moose features
 558
 559 Moose attributes support type-constraint checking, weak reference
 560 creation and type coercion.
 561
 562 =over 4
 563
 564 =item B<clone_and_inherit_options>
 565
 566 This is to support the C<has '+foo'> feature, it clones an attribute
 567 from a superclass and allows a very specific set of changes to be made
 568 to the attribute.
 569
 570 =item B<has_type_constraint>
 571
 572 Returns true if this meta-attribute has a type constraint.
 573
 574 =item B<type_constraint>
 575
 576 A read-only accessor for this meta-attribute's type constraint. For
 577 more information on what you can do with this, see the documentation
 578 for L<Moose::Meta::TypeConstraint>.
 579
 580 =item B<has_handles>
 581
 582 Returns true if this meta-attribute performs delegation.
 583
 584 =item B<handles>
 585
 586 This returns the value which was passed into the handles option.
 587
 588 =item B<is_weak_ref>
 589
 590 Returns true if this meta-attribute produces a weak reference.
 591
 592 =item B<is_required>
 593
 594 Returns true if this meta-attribute is required to have a value.
 595
 596 =item B<is_lazy>
 597
 598 Returns true if this meta-attribute should be initialized lazily.
 599
 600 NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
 601
 602 =item B<is_lazy_build>
 603
 604 Returns true if this meta-attribute should be initialized lazily through
 605 the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
 606 make your attribute required and lazy. In addition it will set the builder, clearer
 607 and predicate options for you using the following convention.
 608
 609    #If your attribute name starts with an underscore:
 610    has '_foo' => (lazy_build => 1);
 611    #is the same as
 612    has '_foo' => (lazy => 1, required => 1, builder => '_build_foo', predicate => '_has_foo', clearer => '_clear_foo');
 613    # or
 614    has '_foo' => (lazy => 1, required => 1, builder => '_build_foo', default => sub{shift->_build_foo}, clearer => '_clear_foo');
 615
 616    #If your attribute name does not start with an underscore:
 617    has 'foo' => (lazy => 1, required => 1, builder => 'build_foo', predicate => 'has_foo', clearer => 'clear_foo');
 618    # or
 619    has '_foo' => (lazy => 1, required => 1, builder => '_build_foo', default => sub{shift->build_foo}, clearer => '_clear_foo');
 620
 621 NOTE: This means your class should provide a method whose name matches the value
 622 of the builder part, in this case _build_foo or build_foo.
 623
 624 =item B<should_coerce>
 625
 626 Returns true if this meta-attribute should perform type coercion.
 627
 628 =item B<should_auto_deref>
 629
 630 Returns true if this meta-attribute should perform automatic
 631 auto-dereferencing.
 632
 633 NOTE: This can only be done for attributes whose type constraint is
 634 either I<ArrayRef> or I<HashRef>.
 635
 636 =item B<has_trigger>
 637
 638 Returns true if this meta-attribute has a trigger set.
 639
 640 =item B<trigger>
 641
 642 This is a CODE reference which will be executed every time the
 643 value of an attribute is assigned. The CODE ref will get two values,
 644 the invocant and the new value. This can be used to handle I<basic>
 645 bi-directional relations.
 646
 647 =item B<documentation>
 648
 649 This is a string which contains the documentation for this attribute.
 650 It serves no direct purpose right now, but it might in the future
 651 in some kind of automated documentation system perhaps.
 652
 653 =item B<has_documentation>
 654
 655 Returns true if this meta-attribute has any documentation.
 656
 657 =back
 658
 659 =head1 BUGS
 660
 661 All complex software has bugs lurking in it, and this module is no
 662 exception. If you find a bug please either email me, or add the bug
 663 to cpan-RT.
 664
 665 =head1 AUTHOR
 666
 667 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 668
 669 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 670
 671 =head1 COPYRIGHT AND LICENSE
 672
 673 Copyright 2006, 2007 by Infinity Interactive, Inc.
 674
 675 L<http://www.iinteractive.com>
 676
 677 This library is free software; you can redistribute it and/or modify
 678 it under the same terms as Perl itself.
 679
 680 =cut