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.12';
  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('coerce'     => (reader => 'should_coerce'    ));
  29 __PACKAGE__->meta->add_attribute('weak_ref'   => (reader => 'is_weak_ref'      ));
  30 __PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
  31 __PACKAGE__->meta->add_attribute('type_constraint' => (
  32     reader    => 'type_constraint',
  33     predicate => 'has_type_constraint',
  34 ));
  35 __PACKAGE__->meta->add_attribute('trigger' => (
  36     reader    => 'trigger',
  37     predicate => 'has_trigger',
  38 ));
  39 __PACKAGE__->meta->add_attribute('handles' => (
  40     reader    => 'handles',
  41     predicate => 'has_handles',
  42 ));
  43 __PACKAGE__->meta->add_attribute('documentation' => (
  44     reader    => 'documentation',
  45     predicate => 'has_documentation',
  46 ));
  47
  48 sub new {
  49         my ($class, $name, %options) = @_;
  50         $class->_process_options($name, \%options);
  51         return $class->SUPER::new($name, %options);
  52 }
  53
  54 sub clone_and_inherit_options {
  55     my ($self, %options) = @_;
  56     # you can change default, required, coerce, documentation and lazy
  57     my %actual_options;
  58     foreach my $legal_option (qw(default coerce required documentation lazy)) {
  59         if (exists $options{$legal_option}) {
  60             $actual_options{$legal_option} = $options{$legal_option};
  61             delete $options{$legal_option};
  62         }
  63     }
  64
  65     # handles can only be added, not changed
  66     if ($options{handles}) {
  67         confess "You can only add the 'handles' option, you cannot change it"
  68             if $self->has_handles;
  69         $actual_options{handles} = $options{handles};
  70         delete $options{handles};
  71     }
  72
  73     # isa can be changed, but only if the
  74     # new type is a subtype
  75     if ($options{isa}) {
  76         my $type_constraint;
  77             if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
  78                         $type_constraint = $options{isa};
  79                 }
  80                 else {
  81                     $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
  82                     (defined $type_constraint)
  83                         || confess "Could not find the type constraint '" . $options{isa} . "'";
  84                 }
  85                 # NOTE:
  86                 # check here to see if the new type
  87                 # is a subtype of the old one
  88                 ($type_constraint->is_subtype_of($self->type_constraint->name))
  89                     || confess "New type constraint setting must be a subtype of inherited one"
  90                         # iff we have a type constraint that is ...
  91                         if $self->has_type_constraint;
  92                 # then we use it :)
  93                 $actual_options{type_constraint} = $type_constraint;
  94         delete $options{isa};
  95     }
  96     (scalar keys %options == 0)
  97         || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
  98     $self->clone(%actual_options);
  99 }
 100
 101 sub _process_options {
 102     my ($class, $name, $options) = @_;
 103
 104         if (exists $options->{is}) {
 105                 if ($options->{is} eq 'ro') {
 106                         $options->{reader} ||= $name;
 107                         (!exists $options->{trigger})
 108                             || confess "Cannot have a trigger on a read-only attribute";
 109                 }
 110                 elsif ($options->{is} eq 'rw') {
 111                         $options->{accessor} = $name;
 112             ((reftype($options->{trigger}) || '') eq 'CODE')
 113                 || confess "Trigger must be a CODE ref"
 114                     if exists $options->{trigger};
 115                 }
 116                 else {
 117                     confess "I do not understand this option (is => " . $options->{is} . ")"
 118                 }
 119         }
 120
 121         if (exists $options->{isa}) {
 122
 123             if (exists $options->{does}) {
 124                 if (eval { $options->{isa}->can('does') }) {
 125                     ($options->{isa}->does($options->{does}))
 126                         || confess "Cannot have an isa option and a does option if the isa does not do the does";
 127                 }
 128                 else {
 129                     confess "Cannot have an isa option which cannot ->does()";
 130                 }
 131             }
 132
 133             # allow for anon-subtypes here ...
 134             if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 135                         $options->{type_constraint} = $options->{isa};
 136                 }
 137                 else {
 138                     $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
 139                         $options->{isa},
 140                         {
 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                         {
 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} && $options->{lazy}) {
 179             (exists $options->{default})
 180                 || confess "You cannot have lazy attribute without specifying a default value for it";
 181         }
 182 }
 183
 184 sub initialize_instance_slot {
 185     my ($self, $meta_instance, $instance, $params) = @_;
 186     my $init_arg = $self->init_arg();
 187     # try to fetch the init arg from the %params ...
 188
 189     my $val;
 190     if (exists $params->{$init_arg}) {
 191         $val = $params->{$init_arg};
 192
 193         if (!defined $val && $self->is_required) {
 194             confess "Attribute (" . $self->name . ") is required and cannot be undef";
 195         }
 196     }
 197     else {
 198         # skip it if it's lazy
 199         return if $self->is_lazy;
 200         # and die if it's required and doesn't have a default value
 201         confess "Attribute (" . $self->name . ") is required"
 202             if $self->is_required && !$self->has_default;
 203     }
 204
 205     # if nothing was in the %params, we can use the
 206     # attribute's default value (if it has one)
 207     if (!defined $val && $self->has_default) {
 208         $val = $self->default($instance);
 209     }
 210
 211         if (defined $val || $self->has_default) {
 212             if ($self->has_type_constraint) {
 213                 my $type_constraint = $self->type_constraint;
 214                     if ($self->should_coerce && $type_constraint->has_coercion) {
 215                         $val = $type_constraint->coerce($val);
 216                     }
 217             (defined($type_constraint->check($val)))
 218                 || confess "Attribute (" .
 219                            $self->name .
 220                            ") does not pass the type constraint (" .
 221                            $type_constraint->name .
 222                            ") with '" .
 223                            (defined $val
 224                                ? (blessed($val) && overload::Overloaded($val)
 225                                     ? overload::StrVal($val)
 226                                     : $val)
 227                                : 'undef') .
 228                            "'";
 229         }
 230         }
 231
 232     $meta_instance->set_slot_value($instance, $self->name, $val);
 233     $meta_instance->weaken_slot_value($instance, $self->name)
 234         if ref $val && $self->is_weak_ref;
 235 }
 236
 237 ## Slot management
 238
 239 sub set_value {
 240     my ($self, $instance, $value) = @_;
 241
 242     my $attr_name = $self->name;
 243
 244     if ($self->is_required) {
 245         defined($value)
 246             || confess "Attribute ($attr_name) is required, so cannot be set to undef";
 247     }
 248
 249     if ($self->has_type_constraint) {
 250
 251         my $type_constraint = $self->type_constraint;
 252
 253         if ($self->should_coerce) {
 254             $value = $type_constraint->coerce($value);
 255         }
 256         defined($type_constraint->_compiled_type_constraint->($value))
 257                 || confess "Attribute ($attr_name) does not pass the type constraint ("
 258                . $type_constraint->name
 259                . ") with "
 260                . (defined($value)
 261                     ? ("'" .
 262                         (blessed($value) && overload::Overloaded($value)
 263                             ? overload::StrVal($value)
 264                             : $value)
 265                         . "'")
 266                     : "undef")
 267           if defined($value);
 268     }
 269
 270     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 271                                          ->get_meta_instance;
 272
 273     $meta_instance->set_slot_value($instance, $attr_name, $value);
 274
 275     if (ref $value && $self->is_weak_ref) {
 276         $meta_instance->weaken_slot_value($instance, $attr_name);
 277     }
 278
 279     if ($self->has_trigger) {
 280         $self->trigger->($instance, $value, $self);
 281     }
 282 }
 283
 284 sub get_value {
 285     my ($self, $instance) = @_;
 286
 287     if ($self->is_lazy) {
 288             unless ($self->has_value($instance)) {
 289                 if ($self->has_default) {
 290                     my $default = $self->default($instance);
 291                     $self->set_value($instance, $default);
 292                 }
 293                 else {
 294                 $self->set_value($instance, undef);
 295                 }
 296             }
 297     }
 298
 299     if ($self->should_auto_deref) {
 300
 301         my $type_constraint = $self->type_constraint;
 302
 303         if ($type_constraint->is_a_type_of('ArrayRef')) {
 304             my $rv = $self->SUPER::get_value($instance);
 305             return unless defined $rv;
 306             return wantarray ? @{ $rv } : $rv;
 307         }
 308         elsif ($type_constraint->is_a_type_of('HashRef')) {
 309             my $rv = $self->SUPER::get_value($instance);
 310             return unless defined $rv;
 311             return wantarray ? %{ $rv } : $rv;
 312         }
 313         else {
 314             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 315         }
 316
 317     }
 318     else {
 319
 320         return $self->SUPER::get_value($instance);
 321     }
 322 }
 323
 324 ## installing accessors
 325
 326 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 327
 328 sub install_accessors {
 329     my $self = shift;
 330     $self->SUPER::install_accessors(@_);
 331
 332     if ($self->has_handles) {
 333
 334         # NOTE:
 335         # Here we canonicalize the 'handles' option
 336         # this will sort out any details and always
 337         # return an hash of methods which we want
 338         # to delagate to, see that method for details
 339         my %handles = $self->_canonicalize_handles();
 340
 341         # find the name of the accessor for this attribute
 342         my $accessor_name = $self->reader || $self->accessor;
 343         (defined $accessor_name)
 344             || confess "You cannot install delegation without a reader or accessor for the attribute";
 345
 346         # make sure we handle HASH accessors correctly
 347         ($accessor_name) = keys %{$accessor_name}
 348             if ref($accessor_name) eq 'HASH';
 349
 350         # install the delegation ...
 351         my $associated_class = $self->associated_class;
 352         foreach my $handle (keys %handles) {
 353             my $method_to_call = $handles{$handle};
 354
 355             (!$associated_class->has_method($handle))
 356                 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 357
 358             # NOTE:
 359             # handles is not allowed to delegate
 360             # any of these methods, as they will
 361             # override the ones in your class, which
 362             # is almost certainly not what you want.
 363             next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 364
 365             if ((reftype($method_to_call) || '') eq 'CODE') {
 366                 $associated_class->add_method($handle => $method_to_call);
 367             }
 368             else {
 369                 $associated_class->add_method($handle => sub {
 370                     # FIXME
 371                     # we should check for lack of
 372                     # a callable return value from
 373                     # the accessor here
 374                     my $proxy = (shift)->$accessor_name();
 375                     @_ = ($proxy, @_);
 376                     goto &{ $proxy->can($method_to_call)};
 377                 });
 378             }
 379         }
 380     }
 381
 382     return;
 383 }
 384
 385 # private methods to help delegation ...
 386
 387 sub _canonicalize_handles {
 388     my $self    = shift;
 389     my $handles = $self->handles;
 390     if (my $handle_type = ref($handles)) {
 391         if ($handle_type eq 'HASH') {
 392             return %{$handles};
 393         }
 394         elsif ($handle_type eq 'ARRAY') {
 395             return map { $_ => $_ } @{$handles};
 396         }
 397         elsif ($handle_type eq 'Regexp') {
 398             ($self->has_type_constraint)
 399                 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 400             return map  { ($_ => $_) }
 401                    grep { /$handles/ } $self->_get_delegate_method_list;
 402         }
 403         elsif ($handle_type eq 'CODE') {
 404             return $handles->($self, $self->_find_delegate_metaclass);
 405         }
 406         else {
 407             confess "Unable to canonicalize the 'handles' option with $handles";
 408         }
 409     }
 410     else {
 411         my $role_meta = eval { $handles->meta };
 412         if ($@) {
 413             confess "Unable to canonicalize the 'handles' option with $handles because : $@";
 414         }
 415
 416         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 417             || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
 418
 419         return map { $_ => $_ } (
 420             $role_meta->get_method_list,
 421             $role_meta->get_required_method_list
 422         );
 423     }
 424 }
 425
 426 sub _find_delegate_metaclass {
 427     my $self = shift;
 428     if (my $class = $self->_isa_metadata) {
 429         # if the class does have
 430         # a meta method, use it
 431         return $class->meta if $class->can('meta');
 432         # otherwise we might be
 433         # dealing with a non-Moose
 434         # class, and need to make
 435         # our own metaclass
 436         return Moose::Meta::Class->initialize($class);
 437     }
 438     elsif (my $role = $self->_does_metadata) {
 439         # our role will always have
 440         # a meta method
 441         return $role->meta;
 442     }
 443     else {
 444         confess "Cannot find delegate metaclass for attribute " . $self->name;
 445     }
 446 }
 447
 448 sub _get_delegate_method_list {
 449     my $self = shift;
 450     my $meta = $self->_find_delegate_metaclass;
 451     if ($meta->isa('Class::MOP::Class')) {
 452         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 453                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 454                     $meta->compute_all_applicable_methods;
 455     }
 456     elsif ($meta->isa('Moose::Meta::Role')) {
 457         return $meta->get_method_list;
 458     }
 459     else {
 460         confess "Unable to recognize the delegate metaclass '$meta'";
 461     }
 462 }
 463
 464 1;
 465
 466 __END__
 467
 468 =pod
 469
 470 =head1 NAME
 471
 472 Moose::Meta::Attribute - The Moose attribute metaclass
 473
 474 =head1 DESCRIPTION
 475
 476 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 477 extensions.
 478
 479 For the most part, the only time you will ever encounter an
 480 instance of this class is if you are doing some serious deep
 481 introspection. To really understand this class, you need to refer
 482 to the L<Class::MOP::Attribute> documentation.
 483
 484 =head1 METHODS
 485
 486 =head2 Overridden methods
 487
 488 These methods override methods in L<Class::MOP::Attribute> and add
 489 Moose specific features. You can safely assume though that they
 490 will behave just as L<Class::MOP::Attribute> does.
 491
 492 =over 4
 493
 494 =item B<new>
 495
 496 =item B<initialize_instance_slot>
 497
 498 =item B<install_accessors>
 499
 500 =item B<accessor_metaclass>
 501
 502 =item B<get_value>
 503
 504 =item B<set_value>
 505
 506   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 507   if($@) {
 508     print "Oops: $@\n";
 509   }
 510
 511 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 512
 513 Before setting the value, a check is made on the type constraint of
 514 the attribute, if it has one, to see if the value passes it. If the
 515 value fails to pass, the set operation dies with a L<Carp/confess>.
 516
 517 Any coercion to convert values is done before checking the type constraint.
 518
 519 To check a value against a type constraint before setting it, fetch the
 520 attribute instance using L<Moose::Meta::Attribute/find_attribute_by_name>,
 521 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 522 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
 523 for an example.
 524
 525 =back
 526
 527 =head2 Additional Moose features
 528
 529 Moose attributes support type-constraint checking, weak reference
 530 creation and type coercion.
 531
 532 =over 4
 533
 534 =item B<clone_and_inherit_options>
 535
 536 This is to support the C<has '+foo'> feature, it clones an attribute
 537 from a superclass and allows a very specific set of changes to be made
 538 to the attribute.
 539
 540 =item B<has_type_constraint>
 541
 542 Returns true if this meta-attribute has a type constraint.
 543
 544 =item B<type_constraint>
 545
 546 A read-only accessor for this meta-attribute's type constraint. For
 547 more information on what you can do with this, see the documentation
 548 for L<Moose::Meta::TypeConstraint>.
 549
 550 =item B<has_handles>
 551
 552 Returns true if this meta-attribute performs delegation.
 553
 554 =item B<handles>
 555
 556 This returns the value which was passed into the handles option.
 557
 558 =item B<is_weak_ref>
 559
 560 Returns true if this meta-attribute produces a weak reference.
 561
 562 =item B<is_required>
 563
 564 Returns true if this meta-attribute is required to have a value.
 565
 566 =item B<is_lazy>
 567
 568 Returns true if this meta-attribute should be initialized lazily.
 569
 570 NOTE: lazy attributes, B<must> have a C<default> field set.
 571
 572 =item B<should_coerce>
 573
 574 Returns true if this meta-attribute should perform type coercion.
 575
 576 =item B<should_auto_deref>
 577
 578 Returns true if this meta-attribute should perform automatic
 579 auto-dereferencing.
 580
 581 NOTE: This can only be done for attributes whose type constraint is
 582 either I<ArrayRef> or I<HashRef>.
 583
 584 =item B<has_trigger>
 585
 586 Returns true if this meta-attribute has a trigger set.
 587
 588 =item B<trigger>
 589
 590 This is a CODE reference which will be executed every time the
 591 value of an attribute is assigned. The CODE ref will get two values,
 592 the invocant and the new value. This can be used to handle I<basic>
 593 bi-directional relations.
 594
 595 =item B<documentation>
 596
 597 This is a string which contains the documentation for this attribute.
 598 It serves no direct purpose right now, but it might in the future
 599 in some kind of automated documentation system perhaps.
 600
 601 =item B<has_documentation>
 602
 603 Returns true if this meta-attribute has any documentation.
 604
 605 =back
 606
 607 =head1 BUGS
 608
 609 All complex software has bugs lurking in it, and this module is no
 610 exception. If you find a bug please either email me, or add the bug
 611 to cpan-RT.
 612
 613 =head1 AUTHOR
 614
 615 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 616
 617 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 618
 619 =head1 COPYRIGHT AND LICENSE
 620
 621 Copyright 2006, 2007 by Infinity Interactive, Inc.
 622
 623 L<http://www.iinteractive.com>
 624
 625 This library is free software; you can redistribute it and/or modify
 626 it under the same terms as Perl itself.
 627
 628 =cut