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