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