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                     return sub {
 126                                 (defined $self->type_constraint->($_[1]))
 127                                         || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
 128                                                 if defined $_[1];
 129                                 $_[0]->{$attr_name} = $_[1];
 130                         };
 131                 }
 132         }
 133         else {
 134                 if ($self->has_weak_ref) {
 135                     return sub {
 136                                 $_[0]->{$attr_name} = $_[1];
 137                                 weaken($_[0]->{$attr_name});
 138                         };
 139                 }
 140                 else {
 141                     return sub { $_[0]->{$attr_name} = $_[1] };
 142                 }
 143         }
 144 }
 145
 146 1;
 147
 148 __END__
 149
 150 =pod
 151
 152 =head1 NAME
 153
 154 Moose::Meta::Attribute - The Moose attribute metaobject
 155
 156 =head1 SYNOPSIS
 157
 158 =head1 DESCRIPTION
 159
 160 This is a subclass of L<Class::MOP::Attribute> with Moose specific
 161 extensions.
 162
 163 =head1 METHODS
 164
 165 =over 4
 166
 167 =item B<new>
 168
 169 =item B<generate_accessor_method>
 170
 171 =item B<generate_writer_method>
 172
 173 =back
 174
 175 =over 4
 176
 177 =item B<has_type_constraint>
 178
 179 =item B<type_constraint>
 180
 181 =item B<has_weak_ref>
 182
 183 =item B<weak_ref>
 184
 185 =item B<coerce>
 186
 187 =item B<has_coercion>
 188
 189 =back
 190
 191 =head1 BUGS
 192
 193 All complex software has bugs lurking in it, and this module is no
 194 exception. If you find a bug please either email me, or add the bug
 195 to cpan-RT.
 196
 197 =head1 AUTHOR
 198
 199 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 200
 201 =head1 COPYRIGHT AND LICENSE
 202
 203 Copyright 2006 by Infinity Interactive, Inc.
 204
 205 L<http://www.iinteractive.com>
 206
 207 This library is free software; you can redistribute it and/or modify
 208 it under the same terms as Perl itself.
 209
 210 =cut