lib/Mouse/Attribute.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Attribute;
   3 use strict;
   4 use warnings;
   5
   6 use Carp 'confess';
   7
   8 sub new {
   9     my $class = shift;
  10     my %args  = @_;
  11
  12     $args{init_arg} = $args{name}
  13         unless exists $args{init_arg};
  14     $args{is} ||= '';
  15
  16     bless \%args, $class;
  17 }
  18
  19 sub name            { $_[0]->{name}            }
  20 sub class           { $_[0]->{class}           }
  21 sub default         { $_[0]->{default}         }
  22 sub predicate       { $_[0]->{predicate}       }
  23 sub clearer         { $_[0]->{clearer}         }
  24 sub handles         { $_[0]->{handles}         }
  25 sub weak_ref        { $_[0]->{weak_ref}        }
  26 sub init_arg        { $_[0]->{init_arg}        }
  27 sub type_constraint { $_[0]->{type_constraint} }
  28
  29 sub generate_accessor {
  30     my $attribute = shift;
  31
  32     my $name       = $attribute->{name};
  33     my $key        = $attribute->{init_arg};
  34     my $default    = $attribute->{default};
  35     my $trigger    = $attribute->{trigger};
  36     my $type       = $attribute->{type_constraint};
  37
  38     my $constraint = sub {
  39         return unless $type;
  40
  41         my $checker = Mouse::TypeRegistry->optimized_constraints->{$type};
  42         return $checker if $checker;
  43
  44         confess "Unable to parse type constraint '$type'";
  45     }->();
  46
  47     my $accessor = 'sub {
  48         my $self = shift;';
  49
  50     if ($attribute->{is} eq 'rw') {
  51         $accessor .= 'if (@_) {
  52             local $_ = $_[0];';
  53
  54         if ($constraint) {
  55             $accessor .= 'Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $_") unless $constraint->();'
  56         }
  57
  58         $accessor .= '$self->{$key} = $_;';
  59
  60         if ($attribute->{weak_ref}) {
  61             $accessor .= 'Scalar::Util::weaken($self->{$key});';
  62         }
  63
  64         if ($trigger) {
  65             $accessor .= '$trigger->($self, $_, $attribute);';
  66         }
  67
  68         $accessor .= '}';
  69     }
  70     else {
  71     }
  72
  73     if ($attribute->{lazy}) {
  74         $accessor .= '$self->{$key} = ';
  75         $accessor .= ref($attribute->{default}) eq 'CODE'
  76                    ? '$default->($self)'
  77                    : '$default';
  78         $accessor .= ' if !exists($self->{$key});';
  79     }
  80
  81     $accessor .= 'return $self->{$key}
  82     }';
  83
  84     return eval $accessor;
  85 }
  86
  87 sub generate_predicate {
  88     my $attribute = shift;
  89     my $key = $attribute->{init_arg};
  90
  91     my $predicate = 'sub { exists($_[0]->{$key}) }';
  92
  93     return eval $predicate;
  94 }
  95
  96 sub generate_clearer {
  97     my $attribute = shift;
  98     my $key = $attribute->{init_arg};
  99
 100     my $predicate = 'sub { delete($_[0]->{$key}) }';
 101
 102     return eval $predicate;
 103 }
 104
 105 sub generate_handles {
 106     my $attribute = shift;
 107     my $reader = $attribute->{name};
 108
 109     my %method_map;
 110
 111     for my $local_method (keys %{ $attribute->{handles} }) {
 112         my $remote_method = $attribute->{handles}{$local_method};
 113
 114         my $method = 'sub {
 115             my $self = shift;
 116             $self->$reader->$remote_method(@_)
 117         }';
 118
 119         $method_map{$local_method} = eval $method;
 120     }
 121
 122     return \%method_map;
 123 }
 124
 125 sub create {
 126     my ($self, $class, $name, %args) = @_;
 127
 128     confess "You must specify a default for lazy attribute '$name'"
 129         if $args{lazy} && !exists($args{default});
 130
 131     confess "Trigger is not allowed on read-only attribute '$name'"
 132         if $args{trigger} && $args{is} ne 'rw';
 133
 134     confess "References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"
 135         if ref($args{default})
 136         && ref($args{default}) ne 'CODE';
 137
 138     $args{handles} = { map { $_ => $_ } @{ $args{handles} } }
 139         if $args{handles}
 140         && ref($args{handles}) eq 'ARRAY';
 141
 142     confess "You must pass a HASH or ARRAY to handles"
 143         if exists($args{handles})
 144         && ref($args{handles}) ne 'HASH';
 145
 146     $args{type_constraint} = delete $args{isa};
 147
 148     my $attribute = $self->new(%args, name => $name, class => $class);
 149     my $meta = $class->meta;
 150
 151     $meta->add_attribute($attribute);
 152
 153     # install an accessor
 154     if ($attribute->{is} eq 'rw' || $attribute->{is} eq 'ro') {
 155         my $accessor = $attribute->generate_accessor;
 156         no strict 'refs';
 157         *{ $class . '::' . $name } = $accessor;
 158     }
 159
 160     for my $method (qw/predicate clearer/) {
 161         if (exists $attribute->{$method}) {
 162             my $generator = "generate_$method";
 163             my $coderef = $attribute->$generator;
 164             no strict 'refs';
 165             *{ $class . '::' . $attribute->{$method} } = $coderef;
 166         }
 167     }
 168
 169     if ($attribute->{handles}) {
 170         my $method_map = $attribute->generate_handles;
 171         for my $method_name (keys %$method_map) {
 172             no strict 'refs';
 173             *{ $class . '::' . $method_name } = $method_map->{$method_name};
 174         }
 175     }
 176
 177     return $attribute;
 178 }
 179
 180 1;
 181
 182 __END__
 183
 184 =head1 NAME
 185
 186 Mouse::Attribute - attribute metaclass
 187
 188 =head1 METHODS
 189
 190 =head2 new %args -> Mouse::Attribute
 191
 192 Instantiates a new Mouse::Attribute. Does nothing else.
 193
 194 =head2 create OwnerClass, AttributeName, %args -> Mouse::Attribute
 195
 196 Creates a new attribute in OwnerClass. Accessors and helper methods are
 197 installed. Some error checking is done.
 198
 199 =head2 name -> AttributeName
 200
 201 =head2 class -> OwnerClass
 202
 203 =head2 default -> Value
 204
 205 =head2 predicate -> MethodName
 206
 207 =head2 clearer -> MethodName
 208
 209 =head2 handles -> { LocalName => RemoteName }
 210
 211 =head2 weak_ref -> Bool
 212
 213 =head2 init_arg -> Str
 214
 215 Informational methods.
 216
 217 =head2 generate_accessor -> CODE
 218
 219 Creates a new code reference for the attribute's accessor.
 220
 221 =head2 generate_predicate -> CODE
 222
 223 Creates a new code reference for the attribute's predicate.
 224
 225 =head2 generate_clearer -> CODE
 226
 227 Creates a new code reference for the attribute's clearer.
 228
 229 =head2 generate_handles -> { MethodName => CODE }
 230
 231 Creates a new code reference for each of the attribute's handles methods.
 232
 233 =cut
 234