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         if (exists $options->{does}) {
 126             if (eval { $options->{isa}->can('does') }) {
 127                 ($options->{isa}->does($options->{does}))
 128                     || confess "Cannot have an isa option and a does option if the isa does not do the does";
 129             }
 130             else {
 131                 confess "Cannot have an isa option which cannot ->does()";
 132             }
 133         }
 134
 135         # allow for anon-subtypes here ...
 136         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 137             $options->{type_constraint} = $options->{isa};
 138         }
 139         else {
 140             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
 141                 $options->{isa} => {
 142                     parent     => Moose::Util::TypeConstraints::find_type_constraint('Object'),
 143                     constraint => sub { $_[0]->isa($options->{isa}) }
 144                 }
 145             );
 146         }
 147     }
 148     elsif (exists $options->{does}) {
 149         # allow for anon-subtypes here ...
 150         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 151                 $options->{type_constraint} = $options->{isa};
 152         }
 153         else {
 154             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
 155                 $options->{does} => {
 156                     parent     => Moose::Util::TypeConstraints::find_type_constraint('Role'),
 157                     constraint => sub { $_[0]->does($options->{does}) }
 158                 }
 159             );
 160         }
 161     }
 162
 163     if (exists $options->{coerce} && $options->{coerce}) {
 164         (exists $options->{type_constraint})
 165             || confess "You cannot have coercion without specifying a type constraint";
 166         confess "You cannot have a weak reference to a coerced value"
 167             if $options->{weak_ref};
 168     }
 169
 170     if (exists $options->{auto_deref} && $options->{auto_deref}) {
 171         (exists $options->{type_constraint})
 172             || confess "You cannot auto-dereference without specifying a type constraint";
 173         ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
 174          $options->{type_constraint}->is_a_type_of('HashRef'))
 175             || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
 176     }
 177
 178     if (exists $options->{lazy_build} && $options->{lazy_build} == 1) {
 179         confess("You can not use lazy_build and default for the same attribute")
 180             if exists $options->{default};
 181         $options->{lazy} = 1;
 182         $options->{required} = 1;
 183             $options->{builder}   ||= "_build_${name}";
 184         if($name =~ /^_/){
 185             $options->{clearer}   ||= "_clear${name}";
 186             $options->{predicate} ||= "_has${name}";
 187         } else {
 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     my $value_is_set;
 207     if (exists $params->{$init_arg}) {
 208         $val = $params->{$init_arg};
 209         $value_is_set = 1;
 210     }
 211     else {
 212         # skip it if it's lazy
 213         return if $self->is_lazy;
 214         # and die if it's required and doesn't have a default value
 215         confess "Attribute (" . $self->name . ") is required"
 216             if $self->is_required && !$self->has_default && !$self->has_builder;
 217
 218         # if nothing was in the %params, we can use the
 219         # attribute's default value (if it has one)
 220         if ($self->has_default) {
 221             $val = $self->default($instance);
 222             $value_is_set = 1;
 223         } elsif ($self->has_builder) {
 224             if(my $builder = $instance->can($self->builder)){
 225                 $val = $instance->$builder;
 226                 $value_is_set = 1;
 227             } else {
 228                 confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
 229             }
 230         }
 231     }
 232
 233     return unless $value_is_set;
 234
 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     $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                 if(my $builder = $instance->can($self->builder)){
 317                     $self->set_value($instance, $instance->$builder);
 318                 } else {
 319                     confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
 320                 }
 321             } else {
 322                 $self->set_value($instance, undef);
 323             }
 324         }
 325     }
 326
 327     if ($self->should_auto_deref) {
 328
 329         my $type_constraint = $self->type_constraint;
 330
 331         if ($type_constraint->is_a_type_of('ArrayRef')) {
 332             my $rv = $self->SUPER::get_value($instance);
 333             return unless defined $rv;
 334             return wantarray ? @{ $rv } : $rv;
 335         }
 336         elsif ($type_constraint->is_a_type_of('HashRef')) {
 337             my $rv = $self->SUPER::get_value($instance);
 338             return unless defined $rv;
 339             return wantarray ? %{ $rv } : $rv;
 340         }
 341         else {
 342             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 343         }
 344
 345     }
 346     else {
 347
 348         return $self->SUPER::get_value($instance);
 349     }
 350 }
 351
 352 ## installing accessors
 353
 354 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 355
 356 sub install_accessors {
 357     my $self = shift;
 358     $self->SUPER::install_accessors(@_);
 359
 360     if ($self->has_handles) {
 361
 362         # NOTE:
 363         # Here we canonicalize the 'handles' option
 364         # this will sort out any details and always
 365         # return an hash of methods which we want
 366         # to delagate to, see that method for details
 367         my %handles = $self->_canonicalize_handles();
 368
 369         # find the accessor method for this attribute
 370         my $accessor = $self->get_read_method_ref;
 371         # then unpack it if we need too ...
 372         $accessor = $accessor->body if blessed $accessor;
 373
 374         # install the delegation ...
 375         my $associated_class = $self->associated_class;
 376         foreach my $handle (keys %handles) {
 377             my $method_to_call = $handles{$handle};
 378
 379             (!$associated_class->has_method($handle))
 380                 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 381
 382             # NOTE:
 383             # handles is not allowed to delegate
 384             # any of these methods, as they will
 385             # override the ones in your class, which
 386             # is almost certainly not what you want.
 387             next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 388
 389             if ((reftype($method_to_call) || '') eq 'CODE') {
 390                 $associated_class->add_method($handle => $method_to_call);
 391             }
 392             else {
 393                 $associated_class->add_method($handle => sub {
 394                     # FIXME
 395                     # we should check for lack of
 396                     # a callable return value from
 397                     # the accessor here
 398                     my $proxy = (shift)->$accessor();
 399                     @_ = ($proxy, @_);
 400                     goto &{ $proxy->can($method_to_call) };
 401                 });
 402             }
 403         }
 404     }
 405
 406     return;
 407 }
 408
 409 # private methods to help delegation ...
 410
 411 sub _canonicalize_handles {
 412     my $self    = shift;
 413     my $handles = $self->handles;
 414     if (my $handle_type = ref($handles)) {
 415         if ($handle_type eq 'HASH') {
 416             return %{$handles};
 417         }
 418         elsif ($handle_type eq 'ARRAY') {
 419             return map { $_ => $_ } @{$handles};
 420         }
 421         elsif ($handle_type eq 'Regexp') {
 422             ($self->has_type_constraint)
 423                 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 424             return map  { ($_ => $_) }
 425                    grep { /$handles/ } $self->_get_delegate_method_list;
 426         }
 427         elsif ($handle_type eq 'CODE') {
 428             return $handles->($self, $self->_find_delegate_metaclass);
 429         }
 430         else {
 431             confess "Unable to canonicalize the 'handles' option with $handles";
 432         }
 433     }
 434     else {
 435         my $role_meta = eval { $handles->meta };
 436         if ($@) {
 437             confess "Unable to canonicalize the 'handles' option with $handles because : $@";
 438         }
 439
 440         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 441             || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
 442
 443         return map { $_ => $_ } (
 444             $role_meta->get_method_list,
 445             $role_meta->get_required_method_list
 446         );
 447     }
 448 }
 449
 450 sub _find_delegate_metaclass {
 451     my $self = shift;
 452     if (my $class = $self->_isa_metadata) {
 453         # if the class does have
 454         # a meta method, use it
 455         return $class->meta if $class->can('meta');
 456         # otherwise we might be
 457         # dealing with a non-Moose
 458         # class, and need to make
 459         # our own metaclass
 460         return Moose::Meta::Class->initialize($class);
 461     }
 462     elsif (my $role = $self->_does_metadata) {
 463         # our role will always have
 464         # a meta method
 465         return $role->meta;
 466     }
 467     else {
 468         confess "Cannot find delegate metaclass for attribute " . $self->name;
 469     }
 470 }
 471
 472 sub _get_delegate_method_list {
 473     my $self = shift;
 474     my $meta = $self->_find_delegate_metaclass;
 475     if ($meta->isa('Class::MOP::Class')) {
 476         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 477                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 478                     $meta->compute_all_applicable_methods;
 479     }
 480     elsif ($meta->isa('Moose::Meta::Role')) {
 481         return $meta->get_method_list;
 482     }
 483     else {
 484         confess "Unable to recognize the delegate metaclass '$meta'";
 485     }
 486 }
 487
 488 1;
 489
 490 __END__
 491
 492 =pod
 493
 494 =head1 NAME
 495
 496 Moose::Meta::Attribute - The Moose attribute metaclass
 497
 498 =head1 DESCRIPTION
 499
 500 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 501 extensions.
 502
 503 For the most part, the only time you will ever encounter an
 504 instance of this class is if you are doing some serious deep
 505 introspection. To really understand this class, you need to refer
 506 to the L<Class::MOP::Attribute> documentation.
 507
 508 =head1 METHODS
 509
 510 =head2 Overridden methods
 511
 512 These methods override methods in L<Class::MOP::Attribute> and add
 513 Moose specific features. You can safely assume though that they
 514 will behave just as L<Class::MOP::Attribute> does.
 515
 516 =over 4
 517
 518 =item B<new>
 519
 520 =item B<initialize_instance_slot>
 521
 522 =item B<install_accessors>
 523
 524 =item B<accessor_metaclass>
 525
 526 =item B<get_value>
 527
 528 =item B<set_value>
 529
 530   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 531   if($@) {
 532     print "Oops: $@\n";
 533   }
 534
 535 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 536
 537 Before setting the value, a check is made on the type constraint of
 538 the attribute, if it has one, to see if the value passes it. If the
 539 value fails to pass, the set operation dies with a L<Carp/confess>.
 540
 541 Any coercion to convert values is done before checking the type constraint.
 542
 543 To check a value against a type constraint before setting it, fetch the
 544 attribute instance using L<Moose::Meta::Attribute/find_attribute_by_name>,
 545 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 546 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
 547 for an example.
 548
 549 =back
 550
 551 =head2 Additional Moose features
 552
 553 Moose attributes support type-constraint checking, weak reference
 554 creation and type coercion.
 555
 556 =over 4
 557
 558 =item B<clone_and_inherit_options>
 559
 560 This is to support the C<has '+foo'> feature, it clones an attribute
 561 from a superclass and allows a very specific set of changes to be made
 562 to the attribute.
 563
 564 =item B<has_type_constraint>
 565
 566 Returns true if this meta-attribute has a type constraint.
 567
 568 =item B<type_constraint>
 569
 570 A read-only accessor for this meta-attribute's type constraint. For
 571 more information on what you can do with this, see the documentation
 572 for L<Moose::Meta::TypeConstraint>.
 573
 574 =item B<has_handles>
 575
 576 Returns true if this meta-attribute performs delegation.
 577
 578 =item B<handles>
 579
 580 This returns the value which was passed into the handles option.
 581
 582 =item B<is_weak_ref>
 583
 584 Returns true if this meta-attribute produces a weak reference.
 585
 586 =item B<is_required>
 587
 588 Returns true if this meta-attribute is required to have a value.
 589
 590 =item B<is_lazy>
 591
 592 Returns true if this meta-attribute should be initialized lazily.
 593
 594 NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
 595
 596 =item B<is_lazy_build>
 597
 598 Returns true if this meta-attribute should be initialized lazily through
 599 the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
 600 make your attribute required and lazy. In addition it will set the builder, clearer
 601 and predicate options for you using the following convention.
 602
 603    #If your attribute name starts with an underscore:
 604    has '_foo' => (lazy_build => 1);
 605    #is the same as
 606    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo);
 607    # or
 608    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
 609
 610    #If your attribute name does not start with an underscore:
 611    has 'foo' => (lazy_build => 1);
 612    #is the same as
 613    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo);
 614    # or
 615    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
 616
 617 The reason for the different naming of the C<builder> is that the C<builder>
 618 method is a private method while the C<clearer> and C<predicate> methods
 619 are public methods.
 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