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
 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                     ((shift)->$accessor_name())->$method_to_call(@_);
 366                 });
 367             }
 368         }
 369     }
 370
 371     return;
 372 }
 373
 374 # private methods to help delegation ...
 375
 376 sub _canonicalize_handles {
 377     my $self    = shift;
 378     my $handles = $self->handles;
 379     if (ref($handles) eq 'HASH') {
 380         return %{$handles};
 381     }
 382     elsif (ref($handles) eq 'ARRAY') {
 383         return map { $_ => $_ } @{$handles};
 384     }
 385     elsif (ref($handles) eq 'Regexp') {
 386         ($self->has_type_constraint)
 387             || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 388         return map  { ($_ => $_) }
 389                grep { /$handles/ } $self->_get_delegate_method_list;
 390     }
 391     elsif (ref($handles) eq 'CODE') {
 392         return $handles->($self, $self->_find_delegate_metaclass);
 393     }
 394     else {
 395         confess "Unable to canonicalize the 'handles' option with $handles";
 396     }
 397 }
 398
 399 sub _find_delegate_metaclass {
 400     my $self = shift;
 401     if (my $class = $self->_isa_metadata) {
 402         # if the class does have
 403         # a meta method, use it
 404         return $class->meta if $class->can('meta');
 405         # otherwise we might be
 406         # dealing with a non-Moose
 407         # class, and need to make
 408         # our own metaclass
 409         return Moose::Meta::Class->initialize($class);
 410     }
 411     elsif (my $role = $self->_does_metadata) {
 412         # our role will always have
 413         # a meta method
 414         return $role->meta;
 415     }
 416     else {
 417         confess "Cannot find delegate metaclass for attribute " . $self->name;
 418     }
 419 }
 420
 421 sub _get_delegate_method_list {
 422     my $self = shift;
 423     my $meta = $self->_find_delegate_metaclass;
 424     if ($meta->isa('Class::MOP::Class')) {
 425         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 426                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 427                     $meta->compute_all_applicable_methods;
 428     }
 429     elsif ($meta->isa('Moose::Meta::Role')) {
 430         return $meta->get_method_list;
 431     }
 432     else {
 433         confess "Unable to recognize the delegate metaclass '$meta'";
 434     }
 435 }
 436
 437 1;
 438
 439 __END__
 440
 441 =pod
 442
 443 =head1 NAME
 444
 445 Moose::Meta::Attribute - The Moose attribute metaclass
 446
 447 =head1 DESCRIPTION
 448
 449 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 450 extensions.
 451
 452 For the most part, the only time you will ever encounter an
 453 instance of this class is if you are doing some serious deep
 454 introspection. To really understand this class, you need to refer
 455 to the L<Class::MOP::Attribute> documentation.
 456
 457 =head1 METHODS
 458
 459 =head2 Overridden methods
 460
 461 These methods override methods in L<Class::MOP::Attribute> and add
 462 Moose specific features. You can safely assume though that they
 463 will behave just as L<Class::MOP::Attribute> does.
 464
 465 =over 4
 466
 467 =item B<new>
 468
 469 =item B<initialize_instance_slot>
 470
 471 =item B<install_accessors>
 472
 473 =item B<accessor_metaclass>
 474
 475 =item B<get_value>
 476
 477 =item B<set_value>
 478
 479 =back
 480
 481 =head2 Additional Moose features
 482
 483 Moose attributes support type-constraint checking, weak reference
 484 creation and type coercion.
 485
 486 =over 4
 487
 488 =item B<clone_and_inherit_options>
 489
 490 This is to support the C<has '+foo'> feature, it clones an attribute
 491 from a superclass and allows a very specific set of changes to be made
 492 to the attribute.
 493
 494 =item B<has_type_constraint>
 495
 496 Returns true if this meta-attribute has a type constraint.
 497
 498 =item B<type_constraint>
 499
 500 A read-only accessor for this meta-attribute's type constraint. For
 501 more information on what you can do with this, see the documentation
 502 for L<Moose::Meta::TypeConstraint>.
 503
 504 =item B<has_handles>
 505
 506 Returns true if this meta-attribute performs delegation.
 507
 508 =item B<handles>
 509
 510 This returns the value which was passed into the handles option.
 511
 512 =item B<is_weak_ref>
 513
 514 Returns true if this meta-attribute produces a weak reference.
 515
 516 =item B<is_required>
 517
 518 Returns true if this meta-attribute is required to have a value.
 519
 520 =item B<is_lazy>
 521
 522 Returns true if this meta-attribute should be initialized lazily.
 523
 524 NOTE: lazy attributes, B<must> have a C<default> field set.
 525
 526 =item B<should_coerce>
 527
 528 Returns true if this meta-attribute should perform type coercion.
 529
 530 =item B<should_auto_deref>
 531
 532 Returns true if this meta-attribute should perform automatic
 533 auto-dereferencing.
 534
 535 NOTE: This can only be done for attributes whose type constraint is
 536 either I<ArrayRef> or I<HashRef>.
 537
 538 =item B<has_trigger>
 539
 540 Returns true if this meta-attribute has a trigger set.
 541
 542 =item B<trigger>
 543
 544 This is a CODE reference which will be executed every time the
 545 value of an attribute is assigned. The CODE ref will get two values,
 546 the invocant and the new value. This can be used to handle I<basic>
 547 bi-directional relations.
 548
 549 =item B<documentation>
 550
 551 This is a string which contains the documentation for this attribute.
 552 It serves no direct purpose right now, but it might in the future
 553 in some kind of automated documentation system perhaps.
 554
 555 =item B<has_documentation>
 556
 557 Returns true if this meta-attribute has any documentation.
 558
 559 =back
 560
 561 =head1 BUGS
 562
 563 All complex software has bugs lurking in it, and this module is no
 564 exception. If you find a bug please either email me, or add the bug
 565 to cpan-RT.
 566
 567 =head1 AUTHOR
 568
 569 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 570
 571 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 572
 573 =head1 COPYRIGHT AND LICENSE
 574
 575 Copyright 2006, 2007 by Infinity Interactive, Inc.
 576
 577 L<http://www.iinteractive.com>
 578
 579 This library is free software; you can redistribute it and/or modify
 580 it under the same terms as Perl itself.
 581
 582 =cut