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->{lazy} && $options->{lazy}) {
 178             (exists $options->{default})
 179                 || confess "You cannot have lazy attribute without specifying a default value for it";
 180         }
 181 }
 182
 183 sub initialize_instance_slot {
 184     my ($self, $meta_instance, $instance, $params) = @_;
 185     my $init_arg = $self->init_arg();
 186     # try to fetch the init arg from the %params ...
 187
 188     my $val;
 189     if (exists $params->{$init_arg}) {
 190         $val = $params->{$init_arg};
 191     }
 192     else {
 193         # skip it if it's lazy
 194         return if $self->is_lazy;
 195         # and die if it's required and doesn't have a default value
 196         confess "Attribute (" . $self->name . ") is required"
 197             if $self->is_required && !$self->has_default;
 198     }
 199
 200     # if nothing was in the %params, we can use the
 201     # attribute's default value (if it has one)
 202     if (!defined $val && $self->has_default) {
 203         $val = $self->default($instance);
 204     }
 205         if (defined $val) {
 206             if ($self->has_type_constraint) {
 207                 my $type_constraint = $self->type_constraint;
 208                     if ($self->should_coerce && $type_constraint->has_coercion) {
 209                         $val = $type_constraint->coercion->coerce($val);
 210                     }
 211             (defined($type_constraint->check($val)))
 212                 || confess "Attribute (" .
 213                            $self->name .
 214                            ") does not pass the type contraint (" .
 215                            $type_constraint->name .
 216                            ") with '$val'";
 217         }
 218         }
 219
 220     $meta_instance->set_slot_value($instance, $self->name, $val);
 221     $meta_instance->weaken_slot_value($instance, $self->name)
 222         if ref $val && $self->is_weak_ref;
 223 }
 224
 225 sub _inline_check_constraint {
 226         my ($self, $value) = @_;
 227         return '' unless $self->has_type_constraint;
 228
 229         # FIXME - remove 'unless defined($value) - constraint Undef
 230         return sprintf <<'EOF', $value, $value, $value, $value
 231 defined($attr->type_constraint->check(%s))
 232         || confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
 233        . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
 234   if defined(%s);
 235 EOF
 236 }
 237
 238 sub _inline_store {
 239         my ($self, $instance, $value) = @_;
 240
 241         my $mi = $self->associated_class->get_meta_instance;
 242         my $slot_name = sprintf "'%s'", $self->slots;
 243
 244     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 245         $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 246             if $self->is_weak_ref;
 247     return $code;
 248 }
 249
 250 sub _inline_trigger {
 251         my ($self, $instance, $value) = @_;
 252         return '' unless $self->has_trigger;
 253         return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 254 }
 255
 256 sub _inline_get {
 257         my ($self, $instance) = @_;
 258
 259         my $mi = $self->associated_class->get_meta_instance;
 260         my $slot_name = sprintf "'%s'", $self->slots;
 261
 262     return $mi->inline_get_slot_value($instance, $slot_name);
 263 }
 264
 265 sub _inline_auto_deref {
 266     my ( $self, $ref_value ) = @_;
 267
 268     return $ref_value unless $self->should_auto_deref;
 269
 270     my $type = $self->type_constraint->name;
 271
 272     my $sigil;
 273     if ($type eq "ArrayRef") {
 274         $sigil = '@';
 275     }
 276     elsif ($type eq 'HashRef') {
 277         $sigil = '%';
 278     }
 279     else {
 280         confess "Can not auto de-reference the type constraint '$type'";
 281     }
 282
 283     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 284 }
 285
 286 sub generate_accessor_method {
 287     my ($attr, $attr_name) = @_;
 288     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
 289         my $mi = $attr->associated_class->get_meta_instance;
 290         my $slot_name = sprintf "'%s'", $attr->slots;
 291         my $inv = '$_[0]';
 292     my $code = 'sub { '
 293     . 'if (scalar(@_) == 2) {'
 294         . ($attr->is_required ?
 295             'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 296             : '')
 297         . ($attr->should_coerce ?
 298             'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
 299             : '')
 300         . $attr->_inline_check_constraint($value_name)
 301                 . $attr->_inline_store($inv, $value_name)
 302                 . $attr->_inline_trigger($inv, $value_name)
 303     . ' }'
 304     . ($attr->is_lazy ?
 305             '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
 306             . 'unless exists $_[0]->{$attr_name};'
 307             : '')
 308     . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
 309     . ' }';
 310     my $sub = eval $code;
 311     warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
 312     confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
 313     return $sub;
 314 }
 315
 316 sub generate_writer_method {
 317     my ($attr, $attr_name) = @_;
 318     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
 319         my $inv = '$_[0]';
 320     my $code = 'sub { '
 321     . ($attr->is_required ?
 322         'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 323         : '')
 324     . ($attr->should_coerce ?
 325         'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
 326         : '')
 327         . $attr->_inline_check_constraint($value_name)
 328         . $attr->_inline_store($inv, $value_name)
 329         . $attr->_inline_trigger($inv, $value_name)
 330     . ' }';
 331     my $sub = eval $code;
 332     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
 333     return $sub;
 334 }
 335
 336 sub generate_reader_method {
 337     my $self = shift;
 338     my $attr_name = $self->slots;
 339     my $code = 'sub {'
 340     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 341     . ($self->is_lazy ?
 342             '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
 343             . 'unless exists $_[0]->{$attr_name};'
 344             : '')
 345     . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
 346     . '}';
 347     my $sub = eval $code;
 348     confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
 349     return $sub;
 350 }
 351
 352 sub install_accessors {
 353     my $self = shift;
 354     $self->SUPER::install_accessors(@_);
 355
 356     if ($self->has_handles) {
 357
 358         # NOTE:
 359         # Here we canonicalize the 'handles' option
 360         # this will sort out any details and always
 361         # return an hash of methods which we want
 362         # to delagate to, see that method for details
 363         my %handles = $self->_canonicalize_handles();
 364
 365         # find the name of the accessor for this attribute
 366         my $accessor_name = $self->reader || $self->accessor;
 367         (defined $accessor_name)
 368             || confess "You cannot install delegation without a reader or accessor for the attribute";
 369
 370         # make sure we handle HASH accessors correctly
 371         ($accessor_name) = keys %{$accessor_name}
 372             if ref($accessor_name) eq 'HASH';
 373
 374         # install the delegation ...
 375         my $associated_class = $self->associated_class;
 376         foreach my $handle (keys %handles) {
 377             my $method_to_call = $handles{$handle};
 378
 379             (!$associated_class->has_method($handle))
 380                 || confess "You cannot overwrite a locally defined method ($handle) with a delegation";
 381
 382             if ((reftype($method_to_call) || '') eq 'CODE') {
 383                 $associated_class->add_method($handle => $method_to_call);
 384             }
 385             else {
 386                 $associated_class->add_method($handle => sub {
 387                     ((shift)->$accessor_name())->$method_to_call(@_);
 388                 });
 389             }
 390         }
 391     }
 392
 393     return;
 394 }
 395
 396 # private methods to help delegation ...
 397
 398 sub _canonicalize_handles {
 399     my $self    = shift;
 400     my $handles = $self->handles;
 401     if (ref($handles) eq 'HASH') {
 402         return %{$handles};
 403     }
 404     elsif (ref($handles) eq 'ARRAY') {
 405         return map { $_ => $_ } @{$handles};
 406     }
 407     elsif (ref($handles) eq 'Regexp') {
 408         ($self->has_type_constraint)
 409             || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 410         return map  { ($_ => $_) }
 411                grep {  $handles  } $self->_get_delegate_method_list;
 412     }
 413     elsif (ref($handles) eq 'CODE') {
 414         return $handles->($self, $self->_find_delegate_metaclass);
 415     }
 416     else {
 417         confess "Unable to canonicalize the 'handles' option with $handles";
 418     }
 419 }
 420
 421 sub _find_delegate_metaclass {
 422     my $self = shift;
 423     if (my $class = $self->_isa_metadata) {
 424         # if the class does have
 425         # a meta method, use it
 426         return $class->meta if $class->can('meta');
 427         # otherwise we might be
 428         # dealing with a non-Moose
 429         # class, and need to make
 430         # our own metaclass
 431         return Moose::Meta::Class->initialize($class);
 432     }
 433     elsif (my $role = $self->_does_metadata) {
 434         # our role will always have
 435         # a meta method
 436         return $role->meta;
 437     }
 438     else {
 439         confess "Cannot find delegate metaclass for attribute " . $self->name;
 440     }
 441 }
 442
 443 sub _get_delegate_method_list {
 444     my $self = shift;
 445     my $meta = $self->_find_delegate_metaclass;
 446     if ($meta->isa('Class::MOP::Class')) {
 447         return map  { $_->{name}                     }
 448                grep { $_->{class} ne 'Moose::Object' }
 449                     $meta->compute_all_applicable_methods;
 450     }
 451     elsif ($meta->isa('Moose::Meta::Role')) {
 452         return $meta->get_method_list;
 453     }
 454     else {
 455         confess "Unable to recognize the delegate metaclass '$meta'";
 456     }
 457 }
 458
 459 1;
 460
 461 __END__
 462
 463 =pod
 464
 465 =head1 NAME
 466
 467 Moose::Meta::Attribute - The Moose attribute metaclass
 468
 469 =head1 DESCRIPTION
 470
 471 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 472 extensions.
 473
 474 For the most part, the only time you will ever encounter an
 475 instance of this class is if you are doing some serious deep
 476 introspection. To really understand this class, you need to refer
 477 to the L<Class::MOP::Attribute> documentation.
 478
 479 =head1 METHODS
 480
 481 =head2 Overridden methods
 482
 483 These methods override methods in L<Class::MOP::Attribute> and add
 484 Moose specific features. You can safely assume though that they
 485 will behave just as L<Class::MOP::Attribute> does.
 486
 487 =over 4
 488
 489 =item B<new>
 490
 491 =item B<clone_and_inherit_options>
 492
 493 =item B<initialize_instance_slot>
 494
 495 =item B<generate_accessor_method>
 496
 497 =item B<generate_writer_method>
 498
 499 =item B<generate_reader_method>
 500
 501 =item B<install_accessors>
 502
 503 =back
 504
 505 =head2 Additional Moose features
 506
 507 Moose attributes support type-contstraint checking, weak reference
 508 creation and type coercion.
 509
 510 =over 4
 511
 512 =item B<has_type_constraint>
 513
 514 Returns true if this meta-attribute has a type constraint.
 515
 516 =item B<type_constraint>
 517
 518 A read-only accessor for this meta-attribute's type constraint. For
 519 more information on what you can do with this, see the documentation
 520 for L<Moose::Meta::TypeConstraint>.
 521
 522 =item B<has_handles>
 523
 524 Returns true if this meta-attribute performs delegation.
 525
 526 =item B<handles>
 527
 528 This returns the value which was passed into the handles option.
 529
 530 =item B<is_weak_ref>
 531
 532 Returns true if this meta-attribute produces a weak reference.
 533
 534 =item B<is_required>
 535
 536 Returns true if this meta-attribute is required to have a value.
 537
 538 =item B<is_lazy>
 539
 540 Returns true if this meta-attribute should be initialized lazily.
 541
 542 NOTE: lazy attributes, B<must> have a C<default> field set.
 543
 544 =item B<should_coerce>
 545
 546 Returns true if this meta-attribute should perform type coercion.
 547
 548 =item B<should_auto_deref>
 549
 550 Returns true if this meta-attribute should perform automatic
 551 auto-dereferencing.
 552
 553 NOTE: This can only be done for attributes whose type constraint is
 554 either I<ArrayRef> or I<HashRef>.
 555
 556 =item B<has_trigger>
 557
 558 Returns true if this meta-attribute has a trigger set.
 559
 560 =item B<trigger>
 561
 562 This is a CODE reference which will be executed every time the
 563 value of an attribute is assigned. The CODE ref will get two values,
 564 the invocant and the new value. This can be used to handle I<basic>
 565 bi-directional relations.
 566
 567 =back
 568
 569 =head1 BUGS
 570
 571 All complex software has bugs lurking in it, and this module is no
 572 exception. If you find a bug please either email me, or add the bug
 573 to cpan-RT.
 574
 575 =head1 AUTHOR
 576
 577 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 578
 579 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 580
 581 =head1 COPYRIGHT AND LICENSE
 582
 583 Copyright 2006 by Infinity Interactive, Inc.
 584
 585 L<http://www.iinteractive.com>
 586
 587 This library is free software; you can redistribute it and/or modify
 588 it under the same terms as Perl itself.
 589
 590 =cut