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                     # FIXME
 395                     # we should check for lack of
 396                     # a callable return value from
 397                     # the accessor here
 398                     ((shift)->$accessor_name())->$method_to_call(@_);
 399                 });
 400             }
 401         }
 402     }
 403
 404     return;
 405 }
 406
 407 # private methods to help delegation ...
 408
 409 sub _canonicalize_handles {
 410     my $self    = shift;
 411     my $handles = $self->handles;
 412     if (ref($handles) eq 'HASH') {
 413         return %{$handles};
 414     }
 415     elsif (ref($handles) eq 'ARRAY') {
 416         return map { $_ => $_ } @{$handles};
 417     }
 418     elsif (ref($handles) eq 'Regexp') {
 419         ($self->has_type_constraint)
 420             || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 421         return map  { ($_ => $_) }
 422                grep {  $handles  } $self->_get_delegate_method_list;
 423     }
 424     elsif (ref($handles) eq 'CODE') {
 425         return $handles->($self, $self->_find_delegate_metaclass);
 426     }
 427     else {
 428         confess "Unable to canonicalize the 'handles' option with $handles";
 429     }
 430 }
 431
 432 sub _find_delegate_metaclass {
 433     my $self = shift;
 434     if (my $class = $self->_isa_metadata) {
 435         # if the class does have
 436         # a meta method, use it
 437         return $class->meta if $class->can('meta');
 438         # otherwise we might be
 439         # dealing with a non-Moose
 440         # class, and need to make
 441         # our own metaclass
 442         return Moose::Meta::Class->initialize($class);
 443     }
 444     elsif (my $role = $self->_does_metadata) {
 445         # our role will always have
 446         # a meta method
 447         return $role->meta;
 448     }
 449     else {
 450         confess "Cannot find delegate metaclass for attribute " . $self->name;
 451     }
 452 }
 453
 454 sub _get_delegate_method_list {
 455     my $self = shift;
 456     my $meta = $self->_find_delegate_metaclass;
 457     if ($meta->isa('Class::MOP::Class')) {
 458         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 459                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 460                     $meta->compute_all_applicable_methods;
 461     }
 462     elsif ($meta->isa('Moose::Meta::Role')) {
 463         return $meta->get_method_list;
 464     }
 465     else {
 466         confess "Unable to recognize the delegate metaclass '$meta'";
 467     }
 468 }
 469
 470 1;
 471
 472 __END__
 473
 474 =pod
 475
 476 =head1 NAME
 477
 478 Moose::Meta::Attribute - The Moose attribute metaclass
 479
 480 =head1 DESCRIPTION
 481
 482 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 483 extensions.
 484
 485 For the most part, the only time you will ever encounter an
 486 instance of this class is if you are doing some serious deep
 487 introspection. To really understand this class, you need to refer
 488 to the L<Class::MOP::Attribute> documentation.
 489
 490 =head1 METHODS
 491
 492 =head2 Overridden methods
 493
 494 These methods override methods in L<Class::MOP::Attribute> and add
 495 Moose specific features. You can safely assume though that they
 496 will behave just as L<Class::MOP::Attribute> does.
 497
 498 =over 4
 499
 500 =item B<new>
 501
 502 =item B<initialize_instance_slot>
 503
 504 =item B<generate_accessor_method>
 505
 506 =item B<generate_writer_method>
 507
 508 =item B<generate_reader_method>
 509
 510 =item B<install_accessors>
 511
 512 =back
 513
 514 =head2 Additional Moose features
 515
 516 Moose attributes support type-constraint checking, weak reference
 517 creation and type coercion.
 518
 519 =over 4
 520
 521 =item B<clone_and_inherit_options>
 522
 523 This is to support the C<has '+foo'> feature, it clones an attribute
 524 from a superclass and allows a very specific set of changes to be made
 525 to the attribute.
 526
 527 =item B<has_type_constraint>
 528
 529 Returns true if this meta-attribute has a type constraint.
 530
 531 =item B<type_constraint>
 532
 533 A read-only accessor for this meta-attribute's type constraint. For
 534 more information on what you can do with this, see the documentation
 535 for L<Moose::Meta::TypeConstraint>.
 536
 537 =item B<has_handles>
 538
 539 Returns true if this meta-attribute performs delegation.
 540
 541 =item B<handles>
 542
 543 This returns the value which was passed into the handles option.
 544
 545 =item B<is_weak_ref>
 546
 547 Returns true if this meta-attribute produces a weak reference.
 548
 549 =item B<is_required>
 550
 551 Returns true if this meta-attribute is required to have a value.
 552
 553 =item B<is_lazy>
 554
 555 Returns true if this meta-attribute should be initialized lazily.
 556
 557 NOTE: lazy attributes, B<must> have a C<default> field set.
 558
 559 =item B<should_coerce>
 560
 561 Returns true if this meta-attribute should perform type coercion.
 562
 563 =item B<should_auto_deref>
 564
 565 Returns true if this meta-attribute should perform automatic
 566 auto-dereferencing.
 567
 568 NOTE: This can only be done for attributes whose type constraint is
 569 either I<ArrayRef> or I<HashRef>.
 570
 571 =item B<has_trigger>
 572
 573 Returns true if this meta-attribute has a trigger set.
 574
 575 =item B<trigger>
 576
 577 This is a CODE reference which will be executed every time the
 578 value of an attribute is assigned. The CODE ref will get two values,
 579 the invocant and the new value. This can be used to handle I<basic>
 580 bi-directional relations.
 581
 582 =back
 583
 584 =head1 BUGS
 585
 586 All complex software has bugs lurking in it, and this module is no
 587 exception. If you find a bug please either email me, or add the bug
 588 to cpan-RT.
 589
 590 =head1 AUTHOR
 591
 592 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 593
 594 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 595
 596 =head1 COPYRIGHT AND LICENSE
 597
 598 Copyright 2006 by Infinity Interactive, Inc.
 599
 600 L<http://www.iinteractive.com>
 601
 602 This library is free software; you can redistribute it and/or modify
 603 it under the same terms as Perl itself.
 604
 605 =cut