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