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