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