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