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