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