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