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