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