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