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