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