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