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 use Moose::Util::TypeConstraints ':no_export';
  11
  12 our $VERSION = '0.02';
  13
  14 use base 'Class::MOP::Attribute';
  15
  16 Moose::Meta::Attribute->meta->add_attribute(
  17     Class::MOP::Attribute->new('coerce' => (
  18         reader    => 'coerce',
  19         predicate => {
  20                         'has_coercion' => sub { $_[0]->coerce() ? 1 : 0 }
  21                 }
  22     ))
  23 );
  24
  25 Moose::Meta::Attribute->meta->add_attribute(
  26     Class::MOP::Attribute->new('weak_ref' => (
  27         reader    => 'weak_ref',
  28         predicate => {
  29                         'has_weak_ref' => sub { $_[0]->weak_ref() ? 1 : 0 }
  30                 }
  31     ))
  32 );
  33
  34 Moose::Meta::Attribute->meta->add_attribute(
  35     Class::MOP::Attribute->new('type_constraint' => (
  36         reader    => 'type_constraint',
  37         predicate => 'has_type_constraint',
  38     ))
  39 );
  40
  41 Moose::Meta::Attribute->meta->add_before_method_modifier('new' => sub {
  42         my (undef, undef, %options) = @_;
  43         if (exists $options{coerce} && $options{coerce}) {
  44             (exists $options{type_constraint})
  45                 || confess "You cannot have coercion without specifying a type constraint";
  46         confess "You cannot have a weak reference to a coerced value"
  47             if $options{weak_ref};
  48         }
  49 });
  50
  51 sub generate_accessor_method {
  52     my ($self, $attr_name) = @_;
  53         if ($self->has_type_constraint) {
  54                 if ($self->has_weak_ref) {
  55                     return sub {
  56                                 if (scalar(@_) == 2) {
  57                                         (defined $self->type_constraint->constraint_code->($_[1]))
  58                                                 || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
  59                                                         if defined $_[1];
  60                                 $_[0]->{$attr_name} = $_[1];
  61                                         weaken($_[0]->{$attr_name});
  62                                 }
  63                         $_[0]->{$attr_name};
  64                     };
  65                 }
  66                 else {
  67                     if ($self->has_coercion) {
  68                     return sub {
  69                                 if (scalar(@_) == 2) {
  70                                     my $val = $self->type_constraint->coercion_code->($_[1]);
  71                                         (defined $self->type_constraint->constraint_code->($val))
  72                                                 || confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
  73                                                         if defined $val;
  74                                 $_[0]->{$attr_name} = $val;
  75                                 }
  76                         $_[0]->{$attr_name};
  77                     };
  78                     }
  79                     else {
  80                     return sub {
  81                                 if (scalar(@_) == 2) {
  82                                         (defined $self->type_constraint->constraint_code->($_[1]))
  83                                                 || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
  84                                                         if defined $_[1];
  85                                 $_[0]->{$attr_name} = $_[1];
  86                                 }
  87                         $_[0]->{$attr_name};
  88                     };
  89                     }
  90                 }
  91         }
  92         else {
  93                 if ($self->has_weak_ref) {
  94                     return sub {
  95                                 if (scalar(@_) == 2) {
  96                                 $_[0]->{$attr_name} = $_[1];
  97                                         weaken($_[0]->{$attr_name});
  98                                 }
  99                         $_[0]->{$attr_name};
 100                     };
 101                 }
 102                 else {
 103                     sub {
 104                             $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
 105                         $_[0]->{$attr_name};
 106                     };
 107                 }
 108         }
 109 }
 110
 111 sub generate_writer_method {
 112     my ($self, $attr_name) = @_;
 113         if ($self->has_type_constraint) {
 114                 if ($self->has_weak_ref) {
 115                     return sub {
 116                                 (defined $self->type_constraint->constraint_code->($_[1]))
 117                                         || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 118                                                 if defined $_[1];
 119                                 $_[0]->{$attr_name} = $_[1];
 120                                 weaken($_[0]->{$attr_name});
 121                         };
 122                 }
 123                 else {
 124                     if ($self->has_coercion) {
 125                     return sub {
 126                         my $val = $self->type_constraint->coercion_code->($_[1]);
 127                                 (defined $self->type_constraint->constraint_code->($val))
 128                                         || confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
 129                                                 if defined $val;
 130                                 $_[0]->{$attr_name} = $val;
 131                         };
 132                     }
 133                     else {
 134                     return sub {
 135                                 (defined $self->type_constraint->constraint_code->($_[1]))
 136                                         || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 137                                                 if defined $_[1];
 138                                 $_[0]->{$attr_name} = $_[1];
 139                         };
 140                 }
 141                 }
 142         }
 143         else {
 144                 if ($self->has_weak_ref) {
 145                     return sub {
 146                                 $_[0]->{$attr_name} = $_[1];
 147                                 weaken($_[0]->{$attr_name});
 148                         };
 149                 }
 150                 else {
 151                     return sub { $_[0]->{$attr_name} = $_[1] };
 152                 }
 153         }
 154 }
 155
 156 1;
 157
 158 __END__
 159
 160 =pod
 161
 162 =head1 NAME
 163
 164 Moose::Meta::Attribute - The Moose attribute metaobject
 165
 166 =head1 SYNOPSIS
 167
 168 =head1 DESCRIPTION
 169
 170 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 171 extensions.
 172
 173 =head1 METHODS
 174
 175 =over 4
 176
 177 =item B<new>
 178
 179 =item B<generate_accessor_method>
 180
 181 =item B<generate_writer_method>
 182
 183 =back
 184
 185 =over 4
 186
 187 =item B<has_type_constraint>
 188
 189 =item B<type_constraint>
 190
 191 =item B<has_weak_ref>
 192
 193 =item B<weak_ref>
 194
 195 =item B<coerce>
 196
 197 =item B<has_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