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 __PACKAGE__->meta->add_attribute('required'   => (reader => 'is_required'      ));
  17 __PACKAGE__->meta->add_attribute('lazy'       => (reader => 'is_lazy'          ));
  18 __PACKAGE__->meta->add_attribute('coerce'     => (reader => 'should_coerce'    ));
  19 __PACKAGE__->meta->add_attribute('weak_ref'   => (reader => 'is_weak_ref'      ));
  20 __PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref'));
  21 __PACKAGE__->meta->add_attribute('type_constraint' => (
  22     reader    => 'type_constraint',
  23     predicate => 'has_type_constraint',
  24 ));
  25 __PACKAGE__->meta->add_attribute('trigger' => (
  26     reader    => 'trigger',
  27     predicate => 'has_trigger',
  28 ));
  29
  30 sub new {
  31         my ($class, $name, %options) = @_;
  32         $class->_process_options($name, \%options);
  33         $class->SUPER::new($name, %options);
  34 }
  35
  36 sub clone_and_inherit_options {
  37     my ($self, %options) = @_;
  38     # you can change default, required and coerce
  39     my %actual_options;
  40     foreach my $legal_option (qw(default coerce required)) {
  41         if (exists $options{$legal_option}) {
  42             $actual_options{$legal_option} = $options{$legal_option};
  43             delete $options{$legal_option};
  44         }
  45     }
  46     # isa can be changed, but only if the
  47     # new type is a subtype
  48     if ($options{isa}) {
  49         my $type_constraint;
  50             if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
  51                         $type_constraint = $options{isa};
  52                 }
  53                 else {
  54                     $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
  55                     (defined $type_constraint)
  56                         || confess "Could not find the type constraint '" . $options{isa} . "'";
  57                 }
  58                 ($type_constraint->is_subtype_of($self->type_constraint->name))
  59                     || confess "New type constraint setting must be a subtype of inherited one"
  60                         if $self->has_type_constraint;
  61                 $actual_options{type_constraint} = $type_constraint;
  62         delete $options{isa};
  63     }
  64     (scalar keys %options == 0)
  65         || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
  66     $self->clone(%actual_options);
  67 }
  68
  69 sub _process_options {
  70     my ($class, $name, $options) = @_;
  71         if (exists $options->{is}) {
  72                 if ($options->{is} eq 'ro') {
  73                         $options->{reader} = $name;
  74                         (!exists $options->{trigger})
  75                             || confess "Cannot have a trigger on a read-only attribute";
  76                 }
  77                 elsif ($options->{is} eq 'rw') {
  78                         $options->{accessor} = $name;
  79                         ((reftype($options->{trigger}) || '') eq 'CODE')
  80                             || confess "A trigger must be a CODE reference"
  81                                 if exists $options->{trigger};
  82                 }
  83         }
  84
  85         if (exists $options->{isa}) {
  86
  87             if (exists $options->{does}) {
  88                 if (eval { $options->{isa}->can('does') }) {
  89                     ($options->{isa}->does($options->{does}))
  90                         || confess "Cannot have an isa option and a does option if the isa does not do the does";
  91                 }
  92                 else {
  93                     confess "Cannot have an isa option which cannot ->does()";
  94                 }
  95             }
  96
  97             # allow for anon-subtypes here ...
  98             if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
  99                         $options->{type_constraint} = $options->{isa};
 100                 }
 101                 else {
 102
 103                     if ($options->{isa} =~ /\|/) {
 104                         my @type_constraints = split /\s*\|\s*/ => $options->{isa};
 105                         $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
 106                             @type_constraints
 107                         );
 108                     }
 109                     else {
 110                     # otherwise assume it is a constraint
 111                     my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});
 112                     # if the constraing it not found ....
 113                     unless (defined $constraint) {
 114                         # assume it is a foreign class, and make
 115                         # an anon constraint for it
 116                         $constraint = Moose::Util::TypeConstraints::subtype(
 117                             'Object',
 118                             Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
 119                         );
 120                     }
 121                 $options->{type_constraint} = $constraint;
 122             }
 123                 }
 124         }
 125         elsif (exists $options->{does}) {
 126             # allow for anon-subtypes here ...
 127             if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
 128                         $options->{type_constraint} = $options->{isa};
 129                 }
 130                 else {
 131                     # otherwise assume it is a constraint
 132                     my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});
 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                             'Role',
 139                             Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
 140                         );
 141                     }
 142             $options->{type_constraint} = $constraint;
 143                 }
 144         }
 145
 146         if (exists $options->{coerce} && $options->{coerce}) {
 147             (exists $options->{type_constraint})
 148                 || confess "You cannot have coercion without specifying a type constraint";
 149             (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
 150                 || confess "You cannot have coercion with a type constraint union";
 151         confess "You cannot have a weak reference to a coerced value"
 152             if $options->{weak_ref};
 153         }
 154
 155         if (exists $options->{lazy} && $options->{lazy}) {
 156             (exists $options->{default})
 157                 || confess "You cannot have lazy attribute without specifying a default value for it";
 158         }
 159 }
 160
 161 sub initialize_instance_slot {
 162     my ($self, $meta_instance, $instance, $params) = @_;
 163     my $init_arg = $self->init_arg();
 164     # try to fetch the init arg from the %params ...
 165
 166     my $val;
 167     if (exists $params->{$init_arg}) {
 168         $val = $params->{$init_arg};
 169     }
 170     else {
 171         # skip it if it's lazy
 172         return if $self->is_lazy;
 173         # and die if it's required and doesn't have a default value
 174         confess "Attribute (" . $self->name . ") is required"
 175             if $self->is_required && !$self->has_default;
 176     }
 177
 178     # if nothing was in the %params, we can use the
 179     # attribute's default value (if it has one)
 180     if (!defined $val && $self->has_default) {
 181         $val = $self->default($instance);
 182     }
 183         if (defined $val) {
 184             if ($self->has_type_constraint) {
 185                 my $type_constraint = $self->type_constraint;
 186                     if ($self->should_coerce && $type_constraint->has_coercion) {
 187                         $val = $type_constraint->coercion->coerce($val);
 188                     }
 189             (defined($type_constraint->check($val)))
 190                 || confess "Attribute (" .
 191                            $self->name .
 192                            ") does not pass the type contraint (" .
 193                            $type_constraint->name .
 194                            ") with '$val'";
 195         }
 196         }
 197
 198     $meta_instance->set_slot_value($instance, $self->name, $val);
 199     $meta_instance->weaken_slot_value($instance, $self->name)
 200         if ref $val && $self->is_weak_ref;
 201 }
 202
 203 sub _inline_check_constraint {
 204         my ($self, $value) = @_;
 205         return '' unless $self->has_type_constraint;
 206
 207         # FIXME - remove 'unless defined($value) - constraint Undef
 208         return sprintf <<'EOF', $value, $value, $value, $value
 209 defined($attr->type_constraint->check(%s))
 210         || confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
 211        . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
 212   if defined(%s);
 213 EOF
 214 }
 215
 216 sub _inline_store {
 217         my ($self, $instance, $value) = @_;
 218
 219         my $mi = $self->associated_class->get_meta_instance;
 220         my $slot_name = sprintf "'%s'", $self->slots;
 221
 222     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 223         $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 224             if $self->is_weak_ref;
 225     return $code;
 226 }
 227
 228 sub _inline_trigger {
 229         my ($self, $instance, $value) = @_;
 230         return '' unless $self->has_trigger;
 231         return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 232 }
 233
 234 sub _inline_get {
 235         my ($self, $instance) = @_;
 236
 237         my $mi = $self->associated_class->get_meta_instance;
 238         my $slot_name = sprintf "'%s'", $self->slots;
 239
 240     return $mi->inline_get_slot_value($instance, $slot_name);
 241 }
 242
 243 sub _inline_auto_deref {
 244     my ( $self, $ref_value ) = @_;
 245
 246     return $ref_value unless $self->should_auto_deref;
 247
 248     my $type = eval { $self->type_constraint->name } || '';
 249     my $sigil;
 250
 251     if ( $type eq "ArrayRef" ) {
 252         $sigil = '@';
 253     } elsif ( $type eq 'HashRef' ) {
 254         $sigil = '%';
 255     } else {
 256         confess "Can't auto deref unless type constraint is ArrayRef or HashRef";
 257     }
 258
 259     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 260 }
 261
 262 sub generate_accessor_method {
 263     my ($attr, $attr_name) = @_;
 264     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
 265         my $mi = $attr->associated_class->get_meta_instance;
 266         my $slot_name = sprintf "'%s'", $attr->slots;
 267         my $inv = '$_[0]';
 268     my $code = 'sub { '
 269     . 'if (scalar(@_) == 2) {'
 270         . ($attr->is_required ?
 271             'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 272             : '')
 273         . ($attr->should_coerce ?
 274             'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
 275             : '')
 276         . $attr->_inline_check_constraint($value_name)
 277                 . $attr->_inline_store($inv, $value_name)
 278                 . $attr->_inline_trigger($inv, $value_name)
 279     . ' }'
 280     . ($attr->is_lazy ?
 281             '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
 282             . 'unless exists $_[0]->{$attr_name};'
 283             : '')
 284     . 'return ' . $attr->_inline_auto_deref( $attr->_inline_get( $inv ) )
 285     . ' }';
 286     my $sub = eval $code;
 287     warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
 288     confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
 289     return $sub;
 290 }
 291
 292 sub generate_writer_method {
 293     my ($attr, $attr_name) = @_;
 294     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
 295         my $inv = '$_[0]';
 296     my $code = 'sub { '
 297     . ($attr->is_required ?
 298         'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 299         : '')
 300     . ($attr->should_coerce ?
 301         'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
 302         : '')
 303         . $attr->_inline_check_constraint($value_name)
 304         . $attr->_inline_store($inv, $value_name)
 305         . $attr->_inline_trigger($inv, $value_name)
 306     . ' }';
 307     my $sub = eval $code;
 308     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
 309     return $sub;
 310 }
 311
 312 sub generate_reader_method {
 313     my $self = shift;
 314     my $attr_name = $self->slots;
 315     my $code = 'sub {'
 316     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 317     . ($self->is_lazy ?
 318             '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
 319             . 'unless exists $_[0]->{$attr_name};'
 320             : '')
 321     . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
 322     . '}';
 323     my $sub = eval $code;
 324     confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
 325     return $sub;
 326 }
 327
 328 1;
 329
 330 __END__
 331
 332 =pod
 333
 334 =head1 NAME
 335
 336 Moose::Meta::Attribute - The Moose attribute metaclass
 337
 338 =head1 DESCRIPTION
 339
 340 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 341 extensions.
 342
 343 For the most part, the only time you will ever encounter an
 344 instance of this class is if you are doing some serious deep
 345 introspection. To really understand this class, you need to refer
 346 to the L<Class::MOP::Attribute> documentation.
 347
 348 =head1 METHODS
 349
 350 =head2 Overridden methods
 351
 352 These methods override methods in L<Class::MOP::Attribute> and add
 353 Moose specific features. You can safely assume though that they
 354 will behave just as L<Class::MOP::Attribute> does.
 355
 356 =over 4
 357
 358 =item B<new>
 359
 360 =item B<clone_and_inherit_options>
 361
 362 =item B<initialize_instance_slot>
 363
 364 =item B<generate_accessor_method>
 365
 366 =item B<generate_writer_method>
 367
 368 =item B<generate_reader_method>
 369
 370 =back
 371
 372 =head2 Additional Moose features
 373
 374 Moose attributes support type-contstraint checking, weak reference
 375 creation and type coercion.
 376
 377 =over 4
 378
 379 =item B<has_type_constraint>
 380
 381 Returns true if this meta-attribute has a type constraint.
 382
 383 =item B<type_constraint>
 384
 385 A read-only accessor for this meta-attribute's type constraint. For
 386 more information on what you can do with this, see the documentation
 387 for L<Moose::Meta::TypeConstraint>.
 388
 389 =item B<is_weak_ref>
 390
 391 Returns true if this meta-attribute produces a weak reference.
 392
 393 =item B<is_required>
 394
 395 Returns true if this meta-attribute is required to have a value.
 396
 397 =item B<is_lazy>
 398
 399 Returns true if this meta-attribute should be initialized lazily.
 400
 401 NOTE: lazy attributes, B<must> have a C<default> field set.
 402
 403 =item B<should_coerce>
 404
 405 Returns true if this meta-attribute should perform type coercion.
 406
 407 =item B<has_trigger>
 408
 409 Returns true if this meta-attribute has a trigger set.
 410
 411 =item B<trigger>
 412
 413 This is a CODE reference which will be executed every time the
 414 value of an attribute is assigned. The CODE ref will get two values,
 415 the invocant and the new value. This can be used to handle I<basic>
 416 bi-directional relations.
 417
 418 =back
 419
 420 =head1 BUGS
 421
 422 All complex software has bugs lurking in it, and this module is no
 423 exception. If you find a bug please either email me, or add the bug
 424 to cpan-RT.
 425
 426 =head1 AUTHOR
 427
 428 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 429
 430 =head1 COPYRIGHT AND LICENSE
 431
 432 Copyright 2006 by Infinity Interactive, Inc.
 433
 434 L<http://www.iinteractive.com>
 435
 436 This library is free software; you can redistribute it and/or modify
 437 it under the same terms as Perl itself.
 438
 439 =cut