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.10';
  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         if (defined $val) {
 216             if ($self->has_type_constraint) {
 217                 my $type_constraint = $self->type_constraint;
 218                     if ($self->should_coerce && $type_constraint->has_coercion) {
 219                         $val = $type_constraint->coerce($val);
 220                     }
 221             (defined($type_constraint->check($val)))
 222                 || confess "Attribute (" .
 223                            $self->name .
 224                            ") does not pass the type constraint (" .
 225                            $type_constraint->name .
 226                            ") with '$val'";
 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 . ") with " . (defined($value) ? ("'" . $value . "'") : "undef")
 257           if defined($value);
 258     }
 259
 260     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 261                                          ->get_meta_instance;
 262
 263     $meta_instance->set_slot_value($instance, $attr_name, $value);
 264
 265     if (ref $value && $self->is_weak_ref) {
 266         $meta_instance->weaken_slot_value($instance, $attr_name);
 267     }
 268
 269     if ($self->has_trigger) {
 270         $self->trigger->($instance, $value, $self);
 271     }
 272 }
 273
 274 sub get_value {
 275     my ($self, $instance) = @_;
 276
 277     if ($self->is_lazy) {
 278             unless ($self->has_value($instance)) {
 279                 if ($self->has_default) {
 280                     my $default = $self->default($instance);
 281                     $self->set_value($instance, $default);
 282                 }
 283                 else {
 284                 $self->set_value($instance, undef);
 285                 }
 286             }
 287     }
 288
 289     if ($self->should_auto_deref) {
 290
 291         my $type_constraint = $self->type_constraint;
 292
 293         if ($type_constraint->is_a_type_of('ArrayRef')) {
 294             my $rv = $self->SUPER::get_value($instance);
 295             return unless defined $rv;
 296             return wantarray ? @{ $rv } : $rv;
 297         }
 298         elsif ($type_constraint->is_a_type_of('HashRef')) {
 299             my $rv = $self->SUPER::get_value($instance);
 300             return unless defined $rv;
 301             return wantarray ? %{ $rv } : $rv;
 302         }
 303         else {
 304             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 305         }
 306
 307     }
 308     else {
 309
 310         return $self->SUPER::get_value($instance);
 311     }
 312 }
 313
 314 ## installing accessors
 315
 316 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 317
 318 sub install_accessors {
 319     my $self = shift;
 320     $self->SUPER::install_accessors(@_);
 321
 322     if ($self->has_handles) {
 323
 324         # NOTE:
 325         # Here we canonicalize the 'handles' option
 326         # this will sort out any details and always
 327         # return an hash of methods which we want
 328         # to delagate to, see that method for details
 329         my %handles = $self->_canonicalize_handles();
 330
 331         # find the name of the accessor for this attribute
 332         my $accessor_name = $self->reader || $self->accessor;
 333         (defined $accessor_name)
 334             || confess "You cannot install delegation without a reader or accessor for the attribute";
 335
 336         # make sure we handle HASH accessors correctly
 337         ($accessor_name) = keys %{$accessor_name}
 338             if ref($accessor_name) eq 'HASH';
 339
 340         # install the delegation ...
 341         my $associated_class = $self->associated_class;
 342         foreach my $handle (keys %handles) {
 343             my $method_to_call = $handles{$handle};
 344
 345             (!$associated_class->has_method($handle))
 346                 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 347
 348             # NOTE:
 349             # handles is not allowed to delegate
 350             # any of these methods, as they will
 351             # override the ones in your class, which
 352             # is almost certainly not what you want.
 353             next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 354
 355             if ((reftype($method_to_call) || '') eq 'CODE') {
 356                 $associated_class->add_method($handle => $method_to_call);
 357             }
 358             else {
 359                 $associated_class->add_method($handle => sub {
 360                     # FIXME
 361                     # we should check for lack of
 362                     # a callable return value from
 363                     # the accessor here
 364                     ((shift)->$accessor_name())->$method_to_call(@_);
 365                 });
 366             }
 367         }
 368     }
 369
 370     return;
 371 }
 372
 373 # private methods to help delegation ...
 374
 375 sub _canonicalize_handles {
 376     my $self    = shift;
 377     my $handles = $self->handles;
 378     if (ref($handles) eq 'HASH') {
 379         return %{$handles};
 380     }
 381     elsif (ref($handles) eq 'ARRAY') {
 382         return map { $_ => $_ } @{$handles};
 383     }
 384     elsif (ref($handles) eq 'Regexp') {
 385         ($self->has_type_constraint)
 386             || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 387         return map  { ($_ => $_) }
 388                grep { /$handles/ } $self->_get_delegate_method_list;
 389     }
 390     elsif (ref($handles) eq 'CODE') {
 391         return $handles->($self, $self->_find_delegate_metaclass);
 392     }
 393     else {
 394         confess "Unable to canonicalize the 'handles' option with $handles";
 395     }
 396 }
 397
 398 sub _find_delegate_metaclass {
 399     my $self = shift;
 400     if (my $class = $self->_isa_metadata) {
 401         # if the class does have
 402         # a meta method, use it
 403         return $class->meta if $class->can('meta');
 404         # otherwise we might be
 405         # dealing with a non-Moose
 406         # class, and need to make
 407         # our own metaclass
 408         return Moose::Meta::Class->initialize($class);
 409     }
 410     elsif (my $role = $self->_does_metadata) {
 411         # our role will always have
 412         # a meta method
 413         return $role->meta;
 414     }
 415     else {
 416         confess "Cannot find delegate metaclass for attribute " . $self->name;
 417     }
 418 }
 419
 420 sub _get_delegate_method_list {
 421     my $self = shift;
 422     my $meta = $self->_find_delegate_metaclass;
 423     if ($meta->isa('Class::MOP::Class')) {
 424         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 425                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 426                     $meta->compute_all_applicable_methods;
 427     }
 428     elsif ($meta->isa('Moose::Meta::Role')) {
 429         return $meta->get_method_list;
 430     }
 431     else {
 432         confess "Unable to recognize the delegate metaclass '$meta'";
 433     }
 434 }
 435
 436 1;
 437
 438 __END__
 439
 440 =pod
 441
 442 =head1 NAME
 443
 444 Moose::Meta::Attribute - The Moose attribute metaclass
 445
 446 =head1 DESCRIPTION
 447
 448 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 449 extensions.
 450
 451 For the most part, the only time you will ever encounter an
 452 instance of this class is if you are doing some serious deep
 453 introspection. To really understand this class, you need to refer
 454 to the L<Class::MOP::Attribute> documentation.
 455
 456 =head1 METHODS
 457
 458 =head2 Overridden methods
 459
 460 These methods override methods in L<Class::MOP::Attribute> and add
 461 Moose specific features. You can safely assume though that they
 462 will behave just as L<Class::MOP::Attribute> does.
 463
 464 =over 4
 465
 466 =item B<new>
 467
 468 =item B<initialize_instance_slot>
 469
 470 =item B<install_accessors>
 471
 472 =item B<accessor_metaclass>
 473
 474 =item B<get_value>
 475
 476 =item B<set_value>
 477
 478 =back
 479
 480 =head2 Additional Moose features
 481
 482 Moose attributes support type-constraint checking, weak reference
 483 creation and type coercion.
 484
 485 =over 4
 486
 487 =item B<clone_and_inherit_options>
 488
 489 This is to support the C<has '+foo'> feature, it clones an attribute
 490 from a superclass and allows a very specific set of changes to be made
 491 to the attribute.
 492
 493 =item B<has_type_constraint>
 494
 495 Returns true if this meta-attribute has a type constraint.
 496
 497 =item B<type_constraint>
 498
 499 A read-only accessor for this meta-attribute's type constraint. For
 500 more information on what you can do with this, see the documentation
 501 for L<Moose::Meta::TypeConstraint>.
 502
 503 =item B<has_handles>
 504
 505 Returns true if this meta-attribute performs delegation.
 506
 507 =item B<handles>
 508
 509 This returns the value which was passed into the handles option.
 510
 511 =item B<is_weak_ref>
 512
 513 Returns true if this meta-attribute produces a weak reference.
 514
 515 =item B<is_required>
 516
 517 Returns true if this meta-attribute is required to have a value.
 518
 519 =item B<is_lazy>
 520
 521 Returns true if this meta-attribute should be initialized lazily.
 522
 523 NOTE: lazy attributes, B<must> have a C<default> field set.
 524
 525 =item B<should_coerce>
 526
 527 Returns true if this meta-attribute should perform type coercion.
 528
 529 =item B<should_auto_deref>
 530
 531 Returns true if this meta-attribute should perform automatic
 532 auto-dereferencing.
 533
 534 NOTE: This can only be done for attributes whose type constraint is
 535 either I<ArrayRef> or I<HashRef>.
 536
 537 =item B<has_trigger>
 538
 539 Returns true if this meta-attribute has a trigger set.
 540
 541 =item B<trigger>
 542
 543 This is a CODE reference which will be executed every time the
 544 value of an attribute is assigned. The CODE ref will get two values,
 545 the invocant and the new value. This can be used to handle I<basic>
 546 bi-directional relations.
 547
 548 =item B<documentation>
 549
 550 This is a string which contains the documentation for this attribute.
 551 It serves no direct purpose right now, but it might in the future
 552 in some kind of automated documentation system perhaps.
 553
 554 =item B<has_documentation>
 555
 556 Returns true if this meta-attribute has any documentation.
 557
 558 =back
 559
 560 =head1 BUGS
 561
 562 All complex software has bugs lurking in it, and this module is no
 563 exception. If you find a bug please either email me, or add the bug
 564 to cpan-RT.
 565
 566 =head1 AUTHOR
 567
 568 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 569
 570 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 571
 572 =head1 COPYRIGHT AND LICENSE
 573
 574 Copyright 2006, 2007 by Infinity Interactive, Inc.
 575
 576 L<http://www.iinteractive.com>
 577
 578 This library is free software; you can redistribute it and/or modify
 579 it under the same terms as Perl itself.
 580
 581 =cut