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