lib/Moose/Meta/Attribute.pm

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