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