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 1;
 137
 138 __END__
 139
 140 =pod
 141
 142 =head1 NAME
 143
 144 Moose::Meta::Attribute - The Moose attribute metaclass
 145
 146 =head1 DESCRIPTION
 147
 148 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 149 extensions.
 150
 151 For the most part, the only time you will ever encounter an
 152 instance of this class is if you are doing some serious deep
 153 introspection. To really understand this class, you need to refer
 154 to the L<Class::MOP::Attribute> documentation.
 155
 156 =head1 METHODS
 157
 158 =head2 Overridden methods
 159
 160 These methods override methods in L<Class::MOP::Attribute> and add
 161 Moose specific features. You can safely assume though that they
 162 will behave just as L<Class::MOP::Attribute> does.
 163
 164 =over 4
 165
 166 =item B<new>
 167
 168 =item B<generate_accessor_method>
 169
 170 =item B<generate_writer_method>
 171
 172 =back
 173
 174 =head2 Additional Moose features
 175
 176 Moose attributes support type-contstraint checking, weak reference
 177 creation and type coercion.
 178
 179 =over 4
 180
 181 =item B<has_type_constraint>
 182
 183 Returns true if this meta-attribute has a type constraint.
 184
 185 =item B<type_constraint>
 186
 187 A read-only accessor for this meta-attribute's type constraint. For
 188 more information on what you can do with this, see the documentation
 189 for L<Moose::Meta::TypeConstraint>.
 190
 191 =item B<is_weak_ref>
 192
 193 Returns true of this meta-attribute produces a weak reference.
 194
 195 =item B<should_coerce>
 196
 197 Returns true of this meta-attribute should perform type coercion.
 198
 199 =back
 200
 201 =head1 BUGS
 202
 203 All complex software has bugs lurking in it, and this module is no
 204 exception. If you find a bug please either email me, or add the bug
 205 to cpan-RT.
 206
 207 =head1 AUTHOR
 208
 209 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 210
 211 =head1 COPYRIGHT AND LICENSE
 212
 213 Copyright 2006 by Infinity Interactive, Inc.
 214
 215 L<http://www.iinteractive.com>
 216
 217 This library is free software; you can redistribute it and/or modify
 218 it under the same terms as Perl itself.
 219
 220 =cut