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