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' => (
  15     reader    => 'coerce',
  16     predicate => { 'has_coercion' => sub { $_[0]->coerce() ? 1 : 0 } }
  17 ));
  18
  19 __PACKAGE__->meta->add_attribute('weak_ref' => (
  20     reader    => 'weak_ref',
  21     predicate => { 'has_weak_ref' => sub { $_[0]->weak_ref() ? 1 : 0 } }
  22 ));
  23
  24 __PACKAGE__->meta->add_attribute('type_constraint' => (
  25     reader    => 'type_constraint',
  26     predicate => 'has_type_constraint',
  27 ));
  28
  29 __PACKAGE__->meta->add_before_method_modifier('new' => sub {
  30         my (undef, undef, %options) = @_;
  31         if (exists $options{coerce} && $options{coerce}) {
  32             (exists $options{type_constraint})
  33                 || confess "You cannot have coercion without specifying a type constraint";
  34         confess "You cannot have a weak reference to a coerced value"
  35             if $options{weak_ref};
  36         }
  37 });
  38
  39 sub generate_accessor_method {
  40     my ($self, $attr_name) = @_;
  41         if ($self->has_type_constraint) {
  42                 if ($self->has_weak_ref) {
  43                     return sub {
  44                                 if (scalar(@_) == 2) {
  45                                         (defined $self->type_constraint->constraint_code->($_[1]))
  46                                                 || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
  47                                                         if defined $_[1];
  48                                 $_[0]->{$attr_name} = $_[1];
  49                                         weaken($_[0]->{$attr_name});
  50                                 }
  51                         $_[0]->{$attr_name};
  52                     };
  53                 }
  54                 else {
  55                     if ($self->has_coercion) {
  56                     return sub {
  57                                 if (scalar(@_) == 2) {
  58                                     my $val = $self->type_constraint->coercion_code->($_[1]);
  59                                         (defined $self->type_constraint->constraint_code->($val))
  60                                                 || confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
  61                                                         if defined $val;
  62                                 $_[0]->{$attr_name} = $val;
  63                                 }
  64                         $_[0]->{$attr_name};
  65                     };
  66                     }
  67                     else {
  68                     return sub {
  69                                 if (scalar(@_) == 2) {
  70                                         (defined $self->type_constraint->constraint_code->($_[1]))
  71                                                 || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
  72                                                         if defined $_[1];
  73                                 $_[0]->{$attr_name} = $_[1];
  74                                 }
  75                         $_[0]->{$attr_name};
  76                     };
  77                     }
  78                 }
  79         }
  80         else {
  81                 if ($self->has_weak_ref) {
  82                     return sub {
  83                                 if (scalar(@_) == 2) {
  84                                 $_[0]->{$attr_name} = $_[1];
  85                                         weaken($_[0]->{$attr_name});
  86                                 }
  87                         $_[0]->{$attr_name};
  88                     };
  89                 }
  90                 else {
  91                     sub {
  92                             $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
  93                         $_[0]->{$attr_name};
  94                     };
  95                 }
  96         }
  97 }
  98
  99 sub generate_writer_method {
 100     my ($self, $attr_name) = @_;
 101         if ($self->has_type_constraint) {
 102                 if ($self->has_weak_ref) {
 103                     return sub {
 104                                 (defined $self->type_constraint->constraint_code->($_[1]))
 105                                         || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 106                                                 if defined $_[1];
 107                                 $_[0]->{$attr_name} = $_[1];
 108                                 weaken($_[0]->{$attr_name});
 109                         };
 110                 }
 111                 else {
 112                     if ($self->has_coercion) {
 113                     return sub {
 114                         my $val = $self->type_constraint->coercion_code->($_[1]);
 115                                 (defined $self->type_constraint->constraint_code->($val))
 116                                         || confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
 117                                                 if defined $val;
 118                                 $_[0]->{$attr_name} = $val;
 119                         };
 120                     }
 121                     else {
 122                     return sub {
 123                                 (defined $self->type_constraint->constraint_code->($_[1]))
 124                                         || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 125                                                 if defined $_[1];
 126                                 $_[0]->{$attr_name} = $_[1];
 127                         };
 128                 }
 129                 }
 130         }
 131         else {
 132                 if ($self->has_weak_ref) {
 133                     return sub {
 134                                 $_[0]->{$attr_name} = $_[1];
 135                                 weaken($_[0]->{$attr_name});
 136                         };
 137                 }
 138                 else {
 139                     return sub { $_[0]->{$attr_name} = $_[1] };
 140                 }
 141         }
 142 }
 143
 144 1;
 145
 146 __END__
 147
 148 =pod
 149
 150 =head1 NAME
 151
 152 Moose::Meta::Attribute - The Moose attribute metaobject
 153
 154 =head1 SYNOPSIS
 155
 156 =head1 DESCRIPTION
 157
 158 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 159 extensions.
 160
 161 =head1 METHODS
 162
 163 =over 4
 164
 165 =item B<new>
 166
 167 =item B<generate_accessor_method>
 168
 169 =item B<generate_writer_method>
 170
 171 =back
 172
 173 =over 4
 174
 175 =item B<has_type_constraint>
 176
 177 =item B<type_constraint>
 178
 179 =item B<has_weak_ref>
 180
 181 =item B<weak_ref>
 182
 183 =item B<coerce>
 184
 185 =item B<has_coercion>
 186
 187 =back
 188
 189 =head1 BUGS
 190
 191 All complex software has bugs lurking in it, and this module is no
 192 exception. If you find a bug please either email me, or add the bug
 193 to cpan-RT.
 194
 195 =head1 AUTHOR
 196
 197 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 198
 199 =head1 COPYRIGHT AND LICENSE
 200
 201 Copyright 2006 by Infinity Interactive, Inc.
 202
 203 L<http://www.iinteractive.com>
 204
 205 This library is free software; you can redistribute it and/or modify
 206 it under the same terms as Perl itself.
 207
 208 =cut