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