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