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