lib/Moose/Meta/Attribute.pm

   1
   2 package Moose::Meta::Attribute;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'weaken', 'reftype';
   8 use Carp         'confess';
   9
  10 our $VERSION = '0.02';
  11
  12 use base 'Class::MOP::Attribute';
  13
  14 __PACKAGE__->meta->add_attribute('required' => (reader => 'is_required'  ));
  15 __PACKAGE__->meta->add_attribute('lazy'     => (reader => 'is_lazy'      ));
  16 __PACKAGE__->meta->add_attribute('coerce'   => (reader => 'should_coerce'));
  17 __PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref'  ));
  18 __PACKAGE__->meta->add_attribute('type_constraint' => (
  19     reader    => 'type_constraint',
  20     predicate => 'has_type_constraint',
  21 ));
  22
  23 __PACKAGE__->meta->add_before_method_modifier('new' => sub {
  24         my (undef, undef, %options) = @_;
  25         if (exists $options{coerce} && $options{coerce}) {
  26             (exists $options{type_constraint})
  27                 || confess "You cannot have coercion without specifying a type constraint";
  28         confess "You cannot have a weak reference to a coerced value"
  29             if $options{weak_ref};
  30         }
  31         if (exists $options{lazy} && $options{lazy}) {
  32             (exists $options{default})
  33                 || confess "You cannot have lazy attribute without specifying a default value for it";
  34         }
  35 });
  36
  37 sub generate_accessor_method {
  38     my ($self, $attr_name) = @_;
  39     my $value_name = $self->should_coerce ? '$val' : '$_[1]';
  40     my $code = 'sub { '
  41     . 'if (scalar(@_) == 2) {'
  42         . ($self->is_required ?
  43             'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
  44             : '')
  45         . ($self->should_coerce ?
  46             'my $val = $self->type_constraint->coercion->coerce($_[1]);'
  47             : '')
  48         . ($self->has_type_constraint ?
  49             ('(defined $self->type_constraint->check(' . $value_name . '))'
  50                 . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
  51                         . 'if defined ' . $value_name . ';')
  52             : '')
  53         . '$_[0]->{$attr_name} = ' . $value_name . ';'
  54         . ($self->is_weak_ref ?
  55             'weaken($_[0]->{$attr_name});'
  56             : '')
  57     . ' }'
  58     . ($self->is_lazy ?
  59             '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
  60             . 'unless exists $_[0]->{$attr_name};'
  61             : '')
  62     . ' $_[0]->{$attr_name};'
  63     . ' }';
  64     my $sub = eval $code;
  65     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
  66     return $sub;
  67 }
  68
  69 sub generate_writer_method {
  70     my ($self, $attr_name) = @_;
  71     my $value_name = $self->should_coerce ? '$val' : '$_[1]';
  72     my $code = 'sub { '
  73     . ($self->is_required ?
  74         'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
  75         : '')
  76     . ($self->should_coerce ?
  77         'my $val = $self->type_constraint->coercion->coerce($_[1]);'
  78         : '')
  79     . ($self->has_type_constraint ?
  80         ('(defined $self->type_constraint->check(' . $value_name . '))'
  81                 . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
  82                         . 'if defined ' . $value_name . ';')
  83         : '')
  84     . '$_[0]->{$attr_name} = ' . $value_name . ';'
  85     . ($self->is_weak_ref ?
  86         'weaken($_[0]->{$attr_name});'
  87         : '')
  88     . ' }';
  89     my $sub = eval $code;
  90     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
  91     return $sub;
  92 }
  93
  94 sub generate_reader_method {
  95     my ($self, $attr_name) = @_;
  96     my $code = 'sub {'
  97     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
  98     . ($self->is_lazy ?
  99             '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
 100             . 'unless exists $_[0]->{$attr_name};'
 101             : '')
 102     . '$_[0]->{$attr_name};'
 103     . '}';
 104     my $sub = eval $code;
 105     confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
 106     return $sub;
 107 }
 108
 109 1;
 110
 111 __END__
 112
 113 =pod
 114
 115 =head1 NAME
 116
 117 Moose::Meta::Attribute - The Moose attribute metaclass
 118
 119 =head1 DESCRIPTION
 120
 121 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 122 extensions.
 123
 124 For the most part, the only time you will ever encounter an
 125 instance of this class is if you are doing some serious deep
 126 introspection. To really understand this class, you need to refer
 127 to the L<Class::MOP::Attribute> documentation.
 128
 129 =head1 METHODS
 130
 131 =head2 Overridden methods
 132
 133 These methods override methods in L<Class::MOP::Attribute> and add
 134 Moose specific features. You can safely assume though that they
 135 will behave just as L<Class::MOP::Attribute> does.
 136
 137 =over 4
 138
 139 =item B<new>
 140
 141 =item B<generate_accessor_method>
 142
 143 =item B<generate_writer_method>
 144
 145 =item B<generate_reader_method>
 146
 147 =back
 148
 149 =head2 Additional Moose features
 150
 151 Moose attributes support type-contstraint checking, weak reference
 152 creation and type coercion.
 153
 154 =over 4
 155
 156 =item B<has_type_constraint>
 157
 158 Returns true if this meta-attribute has a type constraint.
 159
 160 =item B<type_constraint>
 161
 162 A read-only accessor for this meta-attribute's type constraint. For
 163 more information on what you can do with this, see the documentation
 164 for L<Moose::Meta::TypeConstraint>.
 165
 166 =item B<is_weak_ref>
 167
 168 Returns true of this meta-attribute produces a weak reference.
 169
 170 =item B<is_required>
 171
 172 Returns true of this meta-attribute is required to have a value.
 173
 174 =item B<is_lazy>
 175
 176 Returns true of this meta-attribute should be initialized lazily.
 177
 178 NOTE: lazy attributes, B<must> have a C<default> field set.
 179
 180 =item B<should_coerce>
 181
 182 Returns true of this meta-attribute should perform type coercion.
 183
 184 =back
 185
 186 =head1 BUGS
 187
 188 All complex software has bugs lurking in it, and this module is no
 189 exception. If you find a bug please either email me, or add the bug
 190 to cpan-RT.
 191
 192 =head1 AUTHOR
 193
 194 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 195
 196 =head1 COPYRIGHT AND LICENSE
 197
 198 Copyright 2006 by Infinity Interactive, Inc.
 199
 200 L<http://www.iinteractive.com>
 201
 202 This library is free software; you can redistribute it and/or modify
 203 it under the same terms as Perl itself.
 204
 205 =cut