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