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