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