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