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