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