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