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 use overload     ();
  10
  11 our $VERSION   = '0.16';
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use Moose::Meta::Method::Accessor;
  15 use Moose::Util::TypeConstraints ();
  16
  17 use base 'Class::MOP::Attribute';
  18
  19 # options which are not directly used
  20 # but we store them for metadata purposes
  21 __PACKAGE__->meta->add_attribute('isa'  => (reader    => '_isa_metadata'));
  22 __PACKAGE__->meta->add_attribute('does' => (reader    => '_does_metadata'));
  23 __PACKAGE__->meta->add_attribute('is'   => (reader    => '_is_metadata'));
  24
  25 # these are actual options for the attrs
  26 __PACKAGE__->meta->add_attribute('required'   => (reader => 'is_required'      ));
  27 __PACKAGE__->meta->add_attribute('lazy'       => (reader => 'is_lazy'          ));
  28 __PACKAGE__->meta->add_attribute('lazy_build' => (reader => 'is_lazy_build'    ));
  29 __PACKAGE__->meta->add_attribute('coerce'     => (reader => 'should_coerce'    ));
  30 __PACKAGE__->meta->add_attribute('weak_ref'   => (reader => 'is_weak_ref'      ));
  31 __PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
  32 __PACKAGE__->meta->add_attribute('type_constraint' => (
  33     reader    => 'type_constraint',
  34     predicate => 'has_type_constraint',
  35 ));
  36 __PACKAGE__->meta->add_attribute('trigger' => (
  37     reader    => 'trigger',
  38     predicate => 'has_trigger',
  39 ));
  40 __PACKAGE__->meta->add_attribute('handles' => (
  41     reader    => 'handles',
  42     predicate => 'has_handles',
  43 ));
  44 __PACKAGE__->meta->add_attribute('documentation' => (
  45     reader    => 'documentation',
  46     predicate => 'has_documentation',
  47 ));
  48
  49 sub new {
  50     my ($class, $name, %options) = @_;
  51     $class->_process_options($name, \%options);
  52     return $class->SUPER::new($name, %options);
  53 }
  54
  55 sub clone_and_inherit_options {
  56     my ($self, %options) = @_;
  57     # you can change default, required, coerce, documentation and lazy
  58     my %actual_options;
  59     foreach my $legal_option (qw(default coerce required documentation lazy)) {
  60         if (exists $options{$legal_option}) {
  61             $actual_options{$legal_option} = $options{$legal_option};
  62             delete $options{$legal_option};
  63         }
  64     }
  65
  66     # handles can only be added, not changed
  67     if ($options{handles}) {
  68         confess "You can only add the 'handles' option, you cannot change it"
  69             if $self->has_handles;
  70         $actual_options{handles} = $options{handles};
  71         delete $options{handles};
  72     }
  73
  74     # isa can be changed, but only if the
  75     # new type is a subtype
  76     if ($options{isa}) {
  77         my $type_constraint;
  78         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
  79             $type_constraint = $options{isa};
  80         }
  81         else {
  82             $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint(
  83                 $options{isa}
  84             );
  85             (defined $type_constraint)
  86                 || confess "Could not find the type constraint '" . $options{isa} . "'";
  87         }
  88         # NOTE:
  89         # check here to see if the new type
  90         # is a subtype of the old one
  91         ($type_constraint->is_subtype_of($self->type_constraint->name))
  92             || confess "New type constraint setting must be a subtype of inherited one"
  93                 # iff we have a type constraint that is ...
  94                 if $self->has_type_constraint;
  95         # then we use it :)
  96         $actual_options{type_constraint} = $type_constraint;
  97         delete $options{isa};
  98     }
  99     (scalar keys %options == 0)
 100         || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
 101     $self->clone(%actual_options);
 102 }
 103
 104 sub _process_options {
 105     my ($class, $name, $options) = @_;
 106
 107     if (exists $options->{is}) {
 108         if ($options->{is} eq 'ro') {
 109             $options->{reader} ||= $name;
 110             (!exists $options->{trigger})
 111                 || confess "Cannot have a trigger on a read-only attribute";
 112         }
 113         elsif ($options->{is} eq 'rw') {
 114             $options->{accessor} = $name;
 115             ((reftype($options->{trigger}) || '') eq 'CODE')
 116                 || confess "Trigger must be a CODE ref"
 117                     if exists $options->{trigger};
 118         }
 119         else {
 120             confess "I do not understand this option (is => " . $options->{is} . ")"
 121         }
 122     }
 123
 124     if (exists $options->{isa}) {
 125         if (exists $options->{does}) {
 126             if (eval { $options->{isa}->can('does') }) {
 127                 ($options->{isa}->does($options->{does}))
 128                     || confess "Cannot have an isa option and a does option if the isa does not do the does";
 129             }
 130             else {
 131                 confess "Cannot have an isa option which cannot ->does()";
 132             }
 133         }
 134
 135         # allow for anon-subtypes here ...
 136         if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
 137             $options->{type_constraint} = $options->{isa};
 138         }
 139         else {
 140             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
 141                 $options->{isa} => {
 142                     parent     => Moose::Util::TypeConstraints::find_type_constraint('Object'),
 143                     constraint => sub { $_[0]->isa($options->{isa}) }
 144                 }
 145             );
 146         }
 147     }
 148     elsif (exists $options->{does}) {
 149         # allow for anon-subtypes here ...
 150         if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 151                 $options->{type_constraint} = $options->{isa};
 152         }
 153         else {
 154             $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
 155                 $options->{does} => {
 156                     parent     => Moose::Util::TypeConstraints::find_type_constraint('Role'),
 157                     constraint => sub { $_[0]->does($options->{does}) }
 158                 }
 159             );
 160         }
 161     }
 162
 163     if (exists $options->{coerce} && $options->{coerce}) {
 164         (exists $options->{type_constraint})
 165             || confess "You cannot have coercion without specifying a type constraint";
 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->{lazy_build} && $options->{lazy_build} == 1) {
 179         confess("You can not use lazy_build and default for the same attribute")
 180             if exists $options->{default};
 181         $options->{lazy}      = 1;
 182         $options->{required}  = 1;
 183         $options->{builder} ||= "_build_${name}";
 184         if ($name =~ /^_/) {
 185             $options->{clearer}   ||= "_clear${name}";
 186             $options->{predicate} ||= "_has${name}";
 187         }
 188         else {
 189             $options->{clearer}   ||= "clear_${name}";
 190             $options->{predicate} ||= "has_${name}";
 191         }
 192     }
 193
 194     if (exists $options->{lazy} && $options->{lazy}) {
 195         (exists $options->{default} || exists $options->{builder} )
 196             || confess "You cannot have lazy attribute without specifying a default value for it";
 197     }
 198
 199 }
 200
 201 sub initialize_instance_slot {
 202     my ($self, $meta_instance, $instance, $params) = @_;
 203     my $init_arg = $self->init_arg();
 204     # try to fetch the init arg from the %params ...
 205
 206     my $val;
 207     my $value_is_set;
 208     if (exists $params->{$init_arg}) {
 209         $val = $params->{$init_arg};
 210         $value_is_set = 1;
 211     }
 212     else {
 213         # skip it if it's lazy
 214         return if $self->is_lazy;
 215         # and die if it's required and doesn't have a default value
 216         confess "Attribute (" . $self->name . ") is required"
 217             if $self->is_required && !$self->has_default && !$self->has_builder;
 218
 219         # if nothing was in the %params, we can use the
 220         # attribute's default value (if it has one)
 221         if ($self->has_default) {
 222             $val = $self->default($instance);
 223             $value_is_set = 1;
 224         }
 225         elsif ($self->has_builder) {
 226             if (my $builder = $instance->can($self->builder)){
 227                 $val = $instance->$builder;
 228                 $value_is_set = 1;
 229             }
 230             else {
 231                 confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'");
 232             }
 233         }
 234     }
 235
 236     return unless $value_is_set;
 237
 238     if ($self->has_type_constraint) {
 239         my $type_constraint = $self->type_constraint;
 240         if ($self->should_coerce && $type_constraint->has_coercion) {
 241             $val = $type_constraint->coerce($val);
 242         }
 243         (defined($type_constraint->check($val)))
 244             || confess "Attribute (" .
 245                        $self->name .
 246                        ") does not pass the type constraint (" .
 247                        $type_constraint->name .
 248                        ") with '" .
 249                        (defined $val
 250                            ? (blessed($val) && overload::Overloaded($val)
 251                                 ? overload::StrVal($val)
 252                                 : $val)
 253                            : 'undef') .
 254                        "'";
 255     }
 256
 257     $meta_instance->set_slot_value($instance, $self->name, $val);
 258     $meta_instance->weaken_slot_value($instance, $self->name)
 259         if ref $val && $self->is_weak_ref;
 260 }
 261
 262 ## Slot management
 263
 264 sub set_value {
 265     my ($self, $instance, $value) = @_;
 266
 267     my $attr_name = $self->name;
 268
 269     if ($self->is_required) {
 270         defined($value)
 271             || confess "Attribute ($attr_name) is required, so cannot be set to undef";
 272     }
 273
 274     if ($self->has_type_constraint) {
 275
 276         my $type_constraint = $self->type_constraint;
 277
 278         if ($self->should_coerce) {
 279             $value = $type_constraint->coerce($value);
 280         }
 281         defined($type_constraint->_compiled_type_constraint->($value))
 282                 || confess "Attribute ($attr_name) does not pass the type constraint ("
 283                . $type_constraint->name
 284                . ") with "
 285                . (defined($value)
 286                     ? ("'" .
 287                         (blessed($value) && overload::Overloaded($value)
 288                             ? overload::StrVal($value)
 289                             : $value)
 290                         . "'")
 291                     : "undef")
 292           if defined($value);
 293     }
 294
 295     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
 296                                          ->get_meta_instance;
 297
 298     $meta_instance->set_slot_value($instance, $attr_name, $value);
 299
 300     if (ref $value && $self->is_weak_ref) {
 301         $meta_instance->weaken_slot_value($instance, $attr_name);
 302     }
 303
 304     if ($self->has_trigger) {
 305         $self->trigger->($instance, $value, $self);
 306     }
 307 }
 308
 309 sub get_value {
 310     my ($self, $instance) = @_;
 311
 312     if ($self->is_lazy) {
 313         unless ($self->has_value($instance)) {
 314             if ($self->has_default) {
 315                 my $default = $self->default($instance);
 316                 $self->set_value($instance, $default);
 317             }
 318             if ( $self->has_builder ){
 319                 if (my $builder = $instance->can($self->builder)){
 320                     $self->set_value($instance, $instance->$builder);
 321                 }
 322                 else {
 323                     confess(blessed($instance)
 324                           . " does not support builder method '"
 325                           . $self->builder
 326                           . "' for attribute '"
 327                           . $self->name
 328                           . "'");
 329                 }
 330             }
 331             else {
 332                 $self->set_value($instance, undef);
 333             }
 334         }
 335     }
 336
 337     if ($self->should_auto_deref) {
 338
 339         my $type_constraint = $self->type_constraint;
 340
 341         if ($type_constraint->is_a_type_of('ArrayRef')) {
 342             my $rv = $self->SUPER::get_value($instance);
 343             return unless defined $rv;
 344             return wantarray ? @{ $rv } : $rv;
 345         }
 346         elsif ($type_constraint->is_a_type_of('HashRef')) {
 347             my $rv = $self->SUPER::get_value($instance);
 348             return unless defined $rv;
 349             return wantarray ? %{ $rv } : $rv;
 350         }
 351         else {
 352             confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 353         }
 354
 355     }
 356     else {
 357
 358         return $self->SUPER::get_value($instance);
 359     }
 360 }
 361
 362 ## installing accessors
 363
 364 sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 365
 366 sub install_accessors {
 367     my $self = shift;
 368     $self->SUPER::install_accessors(@_);
 369
 370     if ($self->has_handles) {
 371
 372         # NOTE:
 373         # Here we canonicalize the 'handles' option
 374         # this will sort out any details and always
 375         # return an hash of methods which we want
 376         # to delagate to, see that method for details
 377         my %handles = $self->_canonicalize_handles();
 378
 379         # find the accessor method for this attribute
 380         my $accessor = $self->get_read_method_ref;
 381         # then unpack it if we need too ...
 382         $accessor = $accessor->body if blessed $accessor;
 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             # NOTE:
 393             # handles is not allowed to delegate
 394             # any of these methods, as they will
 395             # override the ones in your class, which
 396             # is almost certainly not what you want.
 397             next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 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                     my $proxy = (shift)->$accessor();
 409                     @_ = ($proxy, @_);
 410                     goto &{ $proxy->can($method_to_call) };
 411                 });
 412             }
 413         }
 414     }
 415
 416     return;
 417 }
 418
 419 # private methods to help delegation ...
 420
 421 sub _canonicalize_handles {
 422     my $self    = shift;
 423     my $handles = $self->handles;
 424     if (my $handle_type = ref($handles)) {
 425         if ($handle_type eq 'HASH') {
 426             return %{$handles};
 427         }
 428         elsif ($handle_type eq 'ARRAY') {
 429             return map { $_ => $_ } @{$handles};
 430         }
 431         elsif ($handle_type eq 'Regexp') {
 432             ($self->has_type_constraint)
 433                 || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)";
 434             return map  { ($_ => $_) }
 435                    grep { /$handles/ } $self->_get_delegate_method_list;
 436         }
 437         elsif ($handle_type eq 'CODE') {
 438             return $handles->($self, $self->_find_delegate_metaclass);
 439         }
 440         else {
 441             confess "Unable to canonicalize the 'handles' option with $handles";
 442         }
 443     }
 444     else {
 445         my $role_meta = eval { $handles->meta };
 446         if ($@) {
 447             confess "Unable to canonicalize the 'handles' option with $handles because : $@";
 448         }
 449
 450         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
 451             || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role";
 452
 453         return map { $_ => $_ } (
 454             $role_meta->get_method_list,
 455             $role_meta->get_required_method_list
 456         );
 457     }
 458 }
 459
 460 sub _find_delegate_metaclass {
 461     my $self = shift;
 462     if (my $class = $self->_isa_metadata) {
 463         # if the class does have
 464         # a meta method, use it
 465         return $class->meta if $class->can('meta');
 466         # otherwise we might be
 467         # dealing with a non-Moose
 468         # class, and need to make
 469         # our own metaclass
 470         return Moose::Meta::Class->initialize($class);
 471     }
 472     elsif (my $role = $self->_does_metadata) {
 473         # our role will always have
 474         # a meta method
 475         return $role->meta;
 476     }
 477     else {
 478         confess "Cannot find delegate metaclass for attribute " . $self->name;
 479     }
 480 }
 481
 482 sub _get_delegate_method_list {
 483     my $self = shift;
 484     my $meta = $self->_find_delegate_metaclass;
 485     if ($meta->isa('Class::MOP::Class')) {
 486         return map  { $_->{name}                     }  # NOTE: !never! delegate &meta
 487                grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
 488                     $meta->compute_all_applicable_methods;
 489     }
 490     elsif ($meta->isa('Moose::Meta::Role')) {
 491         return $meta->get_method_list;
 492     }
 493     else {
 494         confess "Unable to recognize the delegate metaclass '$meta'";
 495     }
 496 }
 497
 498 1;
 499
 500 __END__
 501
 502 =pod
 503
 504 =head1 NAME
 505
 506 Moose::Meta::Attribute - The Moose attribute metaclass
 507
 508 =head1 DESCRIPTION
 509
 510 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 511 extensions.
 512
 513 For the most part, the only time you will ever encounter an
 514 instance of this class is if you are doing some serious deep
 515 introspection. To really understand this class, you need to refer
 516 to the L<Class::MOP::Attribute> documentation.
 517
 518 =head1 METHODS
 519
 520 =head2 Overridden methods
 521
 522 These methods override methods in L<Class::MOP::Attribute> and add
 523 Moose specific features. You can safely assume though that they
 524 will behave just as L<Class::MOP::Attribute> does.
 525
 526 =over 4
 527
 528 =item B<new>
 529
 530 =item B<initialize_instance_slot>
 531
 532 =item B<install_accessors>
 533
 534 =item B<accessor_metaclass>
 535
 536 =item B<get_value>
 537
 538 =item B<set_value>
 539
 540   eval { $point->meta->get_attribute('x')->set_value($point, 'fourty-two') };
 541   if($@) {
 542     print "Oops: $@\n";
 543   }
 544
 545 I<Attribute (x) does not pass the type constraint (Int) with 'fourty-two'>
 546
 547 Before setting the value, a check is made on the type constraint of
 548 the attribute, if it has one, to see if the value passes it. If the
 549 value fails to pass, the set operation dies with a L<Carp/confess>.
 550
 551 Any coercion to convert values is done before checking the type constraint.
 552
 553 To check a value against a type constraint before setting it, fetch the
 554 attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
 555 fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
 556 and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
 557 for an example.
 558
 559 =back
 560
 561 =head2 Additional Moose features
 562
 563 Moose attributes support type-constraint checking, weak reference
 564 creation and type coercion.
 565
 566 =over 4
 567
 568 =item B<clone_and_inherit_options>
 569
 570 This is to support the C<has '+foo'> feature, it clones an attribute
 571 from a superclass and allows a very specific set of changes to be made
 572 to the attribute.
 573
 574 =item B<has_type_constraint>
 575
 576 Returns true if this meta-attribute has a type constraint.
 577
 578 =item B<type_constraint>
 579
 580 A read-only accessor for this meta-attribute's type constraint. For
 581 more information on what you can do with this, see the documentation
 582 for L<Moose::Meta::TypeConstraint>.
 583
 584 =item B<has_handles>
 585
 586 Returns true if this meta-attribute performs delegation.
 587
 588 =item B<handles>
 589
 590 This returns the value which was passed into the handles option.
 591
 592 =item B<is_weak_ref>
 593
 594 Returns true if this meta-attribute produces a weak reference.
 595
 596 =item B<is_required>
 597
 598 Returns true if this meta-attribute is required to have a value.
 599
 600 =item B<is_lazy>
 601
 602 Returns true if this meta-attribute should be initialized lazily.
 603
 604 NOTE: lazy attributes, B<must> have a C<default> or C<builder> field set.
 605
 606 =item B<is_lazy_build>
 607
 608 Returns true if this meta-attribute should be initialized lazily through
 609 the builder generated by lazy_build. Using C<lazy_build =E<gt> 1> will
 610 make your attribute required and lazy. In addition it will set the builder, clearer
 611 and predicate options for you using the following convention.
 612
 613    #If your attribute name starts with an underscore:
 614    has '_foo' => (lazy_build => 1);
 615    #is the same as
 616    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo);
 617    # or
 618    has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
 619
 620    #If your attribute name does not start with an underscore:
 621    has 'foo' => (lazy_build => 1);
 622    #is the same as
 623    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo);
 624    # or
 625    has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
 626
 627 The reason for the different naming of the C<builder> is that the C<builder>
 628 method is a private method while the C<clearer> and C<predicate> methods
 629 are public methods.
 630
 631 NOTE: This means your class should provide a method whose name matches the value
 632 of the builder part, in this case _build__foo or _build_foo.
 633
 634 =item B<should_coerce>
 635
 636 Returns true if this meta-attribute should perform type coercion.
 637
 638 =item B<should_auto_deref>
 639
 640 Returns true if this meta-attribute should perform automatic
 641 auto-dereferencing.
 642
 643 NOTE: This can only be done for attributes whose type constraint is
 644 either I<ArrayRef> or I<HashRef>.
 645
 646 =item B<has_trigger>
 647
 648 Returns true if this meta-attribute has a trigger set.
 649
 650 =item B<trigger>
 651
 652 This is a CODE reference which will be executed every time the
 653 value of an attribute is assigned. The CODE ref will get two values,
 654 the invocant and the new value. This can be used to handle I<basic>
 655 bi-directional relations.
 656
 657 =item B<documentation>
 658
 659 This is a string which contains the documentation for this attribute.
 660 It serves no direct purpose right now, but it might in the future
 661 in some kind of automated documentation system perhaps.
 662
 663 =item B<has_documentation>
 664
 665 Returns true if this meta-attribute has any documentation.
 666
 667 =back
 668
 669 =head1 BUGS
 670
 671 All complex software has bugs lurking in it, and this module is no
 672 exception. If you find a bug please either email me, or add the bug
 673 to cpan-RT.
 674
 675 =head1 AUTHOR
 676
 677 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 678
 679 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 680
 681 =head1 COPYRIGHT AND LICENSE
 682
 683 Copyright 2006-2008 by Infinity Interactive, Inc.
 684
 685 L<http://www.iinteractive.com>
 686
 687 This library is free software; you can redistribute it and/or modify
 688 it under the same terms as Perl itself.
 689
 690 =cut