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