lib/Moose/Meta/Attribute.pm

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