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