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 = shift;
 292     my $attr_name = $self->name;
 293     my $code = 'sub {'
 294     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 295     . ($self->is_lazy ?
 296             '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
 297             . 'unless exists $_[0]->{$attr_name};'
 298             : '')
 299     . 'return $_[0]->{$attr_name};'
 300     . '}';
 301     my $sub = eval $code;
 302     confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
 303     return $sub;
 304 }
 305
 306 1;
 307
 308 __END__
 309
 310 =pod
 311
 312 =head1 NAME
 313
 314 Moose::Meta::Attribute - The Moose attribute metaclass
 315
 316 =head1 DESCRIPTION
 317
 318 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 319 extensions.
 320
 321 For the most part, the only time you will ever encounter an
 322 instance of this class is if you are doing some serious deep
 323 introspection. To really understand this class, you need to refer
 324 to the L<Class::MOP::Attribute> documentation.
 325
 326 =head1 METHODS
 327
 328 =head2 Overridden methods
 329
 330 These methods override methods in L<Class::MOP::Attribute> and add
 331 Moose specific features. You can safely assume though that they
 332 will behave just as L<Class::MOP::Attribute> does.
 333
 334 =over 4
 335
 336 =item B<new>
 337
 338 =item B<clone_and_inherit_options>
 339
 340 =item B<initialize_instance_slot>
 341
 342 =item B<generate_accessor_method>
 343
 344 =item B<generate_writer_method>
 345
 346 =item B<generate_reader_method>
 347
 348 =back
 349
 350 =head2 Additional Moose features
 351
 352 Moose attributes support type-contstraint checking, weak reference
 353 creation and type coercion.
 354
 355 =over 4
 356
 357 =item B<has_type_constraint>
 358
 359 Returns true if this meta-attribute has a type constraint.
 360
 361 =item B<type_constraint>
 362
 363 A read-only accessor for this meta-attribute's type constraint. For
 364 more information on what you can do with this, see the documentation
 365 for L<Moose::Meta::TypeConstraint>.
 366
 367 =item B<is_weak_ref>
 368
 369 Returns true if this meta-attribute produces a weak reference.
 370
 371 =item B<is_required>
 372
 373 Returns true if this meta-attribute is required to have a value.
 374
 375 =item B<is_lazy>
 376
 377 Returns true if this meta-attribute should be initialized lazily.
 378
 379 NOTE: lazy attributes, B<must> have a C<default> field set.
 380
 381 =item B<should_coerce>
 382
 383 Returns true if this meta-attribute should perform type coercion.
 384
 385 =item B<has_trigger>
 386
 387 Returns true if this meta-attribute has a trigger set.
 388
 389 =item B<trigger>
 390
 391 This is a CODE reference which will be executed every time the
 392 value of an attribute is assigned. The CODE ref will get two values,
 393 the invocant and the new value. This can be used to handle I<basic>
 394 bi-directional relations.
 395
 396 =back
 397
 398 =head1 BUGS
 399
 400 All complex software has bugs lurking in it, and this module is no
 401 exception. If you find a bug please either email me, or add the bug
 402 to cpan-RT.
 403
 404 =head1 AUTHOR
 405
 406 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 407
 408 =head1 COPYRIGHT AND LICENSE
 409
 410 Copyright 2006 by Infinity Interactive, Inc.
 411
 412 L<http://www.iinteractive.com>
 413
 414 This library is free software; you can redistribute it and/or modify
 415 it under the same terms as Perl itself.
 416
 417 =cut