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