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