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