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->{auto_deref} && $options->{auto_deref}) {
 156             (exists $options->{type_constraint})
 157                 || confess "You cannot auto-dereference without specifying a type constraint";
 158             ($options->{type_constraint}->name =~ /^ArrayRef|HashRef$/)
 159                 || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
 160         }
 161
 162         if (exists $options->{lazy} && $options->{lazy}) {
 163             (exists $options->{default})
 164                 || confess "You cannot have lazy attribute without specifying a default value for it";
 165         }
 166 }
 167
 168 sub initialize_instance_slot {
 169     my ($self, $meta_instance, $instance, $params) = @_;
 170     my $init_arg = $self->init_arg();
 171     # try to fetch the init arg from the %params ...
 172
 173     my $val;
 174     if (exists $params->{$init_arg}) {
 175         $val = $params->{$init_arg};
 176     }
 177     else {
 178         # skip it if it's lazy
 179         return if $self->is_lazy;
 180         # and die if it's required and doesn't have a default value
 181         confess "Attribute (" . $self->name . ") is required"
 182             if $self->is_required && !$self->has_default;
 183     }
 184
 185     # if nothing was in the %params, we can use the
 186     # attribute's default value (if it has one)
 187     if (!defined $val && $self->has_default) {
 188         $val = $self->default($instance);
 189     }
 190         if (defined $val) {
 191             if ($self->has_type_constraint) {
 192                 my $type_constraint = $self->type_constraint;
 193                     if ($self->should_coerce && $type_constraint->has_coercion) {
 194                         $val = $type_constraint->coercion->coerce($val);
 195                     }
 196             (defined($type_constraint->check($val)))
 197                 || confess "Attribute (" .
 198                            $self->name .
 199                            ") does not pass the type contraint (" .
 200                            $type_constraint->name .
 201                            ") with '$val'";
 202         }
 203         }
 204
 205     $meta_instance->set_slot_value($instance, $self->name, $val);
 206     $meta_instance->weaken_slot_value($instance, $self->name)
 207         if ref $val && $self->is_weak_ref;
 208 }
 209
 210 sub _inline_check_constraint {
 211         my ($self, $value) = @_;
 212         return '' unless $self->has_type_constraint;
 213
 214         # FIXME - remove 'unless defined($value) - constraint Undef
 215         return sprintf <<'EOF', $value, $value, $value, $value
 216 defined($attr->type_constraint->check(%s))
 217         || confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
 218        . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
 219   if defined(%s);
 220 EOF
 221 }
 222
 223 sub _inline_store {
 224         my ($self, $instance, $value) = @_;
 225
 226         my $mi = $self->associated_class->get_meta_instance;
 227         my $slot_name = sprintf "'%s'", $self->slots;
 228
 229     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 230         $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 231             if $self->is_weak_ref;
 232     return $code;
 233 }
 234
 235 sub _inline_trigger {
 236         my ($self, $instance, $value) = @_;
 237         return '' unless $self->has_trigger;
 238         return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 239 }
 240
 241 sub _inline_get {
 242         my ($self, $instance) = @_;
 243
 244         my $mi = $self->associated_class->get_meta_instance;
 245         my $slot_name = sprintf "'%s'", $self->slots;
 246
 247     return $mi->inline_get_slot_value($instance, $slot_name);
 248 }
 249
 250 sub _inline_auto_deref {
 251     my ( $self, $ref_value ) = @_;
 252
 253     return $ref_value unless $self->should_auto_deref;
 254
 255     my $type = $self->type_constraint->name;
 256
 257     my $sigil;
 258     if ($type eq "ArrayRef") {
 259         $sigil = '@';
 260     }
 261     elsif ($type eq 'HashRef') {
 262         $sigil = '%';
 263     }
 264     else {
 265         confess "Can not auto de-reference the type constraint '$type'";
 266     }
 267
 268     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 269 }
 270
 271 sub generate_accessor_method {
 272     my ($attr, $attr_name) = @_;
 273     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
 274         my $mi = $attr->associated_class->get_meta_instance;
 275         my $slot_name = sprintf "'%s'", $attr->slots;
 276         my $inv = '$_[0]';
 277     my $code = 'sub { '
 278     . 'if (scalar(@_) == 2) {'
 279         . ($attr->is_required ?
 280             'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 281             : '')
 282         . ($attr->should_coerce ?
 283             'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
 284             : '')
 285         . $attr->_inline_check_constraint($value_name)
 286                 . $attr->_inline_store($inv, $value_name)
 287                 . $attr->_inline_trigger($inv, $value_name)
 288     . ' }'
 289     . ($attr->is_lazy ?
 290             '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
 291             . 'unless exists $_[0]->{$attr_name};'
 292             : '')
 293     . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
 294     . ' }';
 295     my $sub = eval $code;
 296     warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
 297     confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
 298     return $sub;
 299 }
 300
 301 sub generate_writer_method {
 302     my ($attr, $attr_name) = @_;
 303     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
 304         my $inv = '$_[0]';
 305     my $code = 'sub { '
 306     . ($attr->is_required ?
 307         'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 308         : '')
 309     . ($attr->should_coerce ?
 310         'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
 311         : '')
 312         . $attr->_inline_check_constraint($value_name)
 313         . $attr->_inline_store($inv, $value_name)
 314         . $attr->_inline_trigger($inv, $value_name)
 315     . ' }';
 316     my $sub = eval $code;
 317     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
 318     return $sub;
 319 }
 320
 321 sub generate_reader_method {
 322     my $self = shift;
 323     my $attr_name = $self->slots;
 324     my $code = 'sub {'
 325     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 326     . ($self->is_lazy ?
 327             '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
 328             . 'unless exists $_[0]->{$attr_name};'
 329             : '')
 330     . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
 331     . '}';
 332     my $sub = eval $code;
 333     confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
 334     return $sub;
 335 }
 336
 337 1;
 338
 339 __END__
 340
 341 =pod
 342
 343 =head1 NAME
 344
 345 Moose::Meta::Attribute - The Moose attribute metaclass
 346
 347 =head1 DESCRIPTION
 348
 349 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 350 extensions.
 351
 352 For the most part, the only time you will ever encounter an
 353 instance of this class is if you are doing some serious deep
 354 introspection. To really understand this class, you need to refer
 355 to the L<Class::MOP::Attribute> documentation.
 356
 357 =head1 METHODS
 358
 359 =head2 Overridden methods
 360
 361 These methods override methods in L<Class::MOP::Attribute> and add
 362 Moose specific features. You can safely assume though that they
 363 will behave just as L<Class::MOP::Attribute> does.
 364
 365 =over 4
 366
 367 =item B<new>
 368
 369 =item B<clone_and_inherit_options>
 370
 371 =item B<initialize_instance_slot>
 372
 373 =item B<generate_accessor_method>
 374
 375 =item B<generate_writer_method>
 376
 377 =item B<generate_reader_method>
 378
 379 =back
 380
 381 =head2 Additional Moose features
 382
 383 Moose attributes support type-contstraint checking, weak reference
 384 creation and type coercion.
 385
 386 =over 4
 387
 388 =item B<has_type_constraint>
 389
 390 Returns true if this meta-attribute has a type constraint.
 391
 392 =item B<type_constraint>
 393
 394 A read-only accessor for this meta-attribute's type constraint. For
 395 more information on what you can do with this, see the documentation
 396 for L<Moose::Meta::TypeConstraint>.
 397
 398 =item B<is_weak_ref>
 399
 400 Returns true if this meta-attribute produces a weak reference.
 401
 402 =item B<is_required>
 403
 404 Returns true if this meta-attribute is required to have a value.
 405
 406 =item B<is_lazy>
 407
 408 Returns true if this meta-attribute should be initialized lazily.
 409
 410 NOTE: lazy attributes, B<must> have a C<default> field set.
 411
 412 =item B<should_coerce>
 413
 414 Returns true if this meta-attribute should perform type coercion.
 415
 416 =item B<should_auto_deref>
 417
 418 Returns true if this meta-attribute should perform automatic
 419 auto-dereferencing.
 420
 421 NOTE: This can only be done for attributes whose type constraint is
 422 either I<ArrayRef> or I<HashRef>.
 423
 424 =item B<has_trigger>
 425
 426 Returns true if this meta-attribute has a trigger set.
 427
 428 =item B<trigger>
 429
 430 This is a CODE reference which will be executed every time the
 431 value of an attribute is assigned. The CODE ref will get two values,
 432 the invocant and the new value. This can be used to handle I<basic>
 433 bi-directional relations.
 434
 435 =back
 436
 437 =head1 BUGS
 438
 439 All complex software has bugs lurking in it, and this module is no
 440 exception. If you find a bug please either email me, or add the bug
 441 to cpan-RT.
 442
 443 =head1 AUTHOR
 444
 445 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 446
 447 =head1 COPYRIGHT AND LICENSE
 448
 449 Copyright 2006 by Infinity Interactive, Inc.
 450
 451 L<http://www.iinteractive.com>
 452
 453 This library is free software; you can redistribute it and/or modify
 454 it under the same terms as Perl itself.
 455
 456 =cut