lib/Class/MOP/Attribute.pm

   1
   2 package Class::MOP::Attribute;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'reftype';
   9
  10 use Class::MOP::Class;
  11 use Class::MOP::Method;
  12
  13 our $VERSION = '0.01';
  14
  15 sub meta { Class::MOP::Class->initialize($_[0]) }
  16
  17 sub new {
  18     my $class   = shift;
  19     my $name    = shift;
  20     my %options = @_;
  21
  22     (defined $name && $name)
  23         || confess "You must provide a name for the attribute";
  24     (!exists $options{reader} && !exists $options{writer})
  25         || confess "You cannot declare an accessor and reader and/or writer functions"
  26             if exists $options{accessor};
  27
  28     bless {
  29         name      => $name,
  30         accessor  => $options{accessor},
  31         reader    => $options{reader},
  32         writer    => $options{writer},
  33         predicate => $options{predicate},
  34         init_arg  => $options{init_arg},
  35         default   => $options{default}
  36     } => $class;
  37 }
  38
  39 sub name { $_[0]->{name} }
  40
  41 sub has_accessor  { defined($_[0]->{accessor}) ? 1 : 0  }
  42 sub has_reader    { defined($_[0]->{reader}) ? 1 : 0    }
  43 sub has_writer    { defined($_[0]->{writer}) ? 1 : 0    }
  44 sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
  45 sub has_init_arg  { defined($_[0]->{init_arg}) ? 1 : 0  }
  46 sub has_default   { defined($_[0]->{default}) ? 1 : 0   }
  47
  48 sub accessor  { $_[0]->{accessor}  }
  49 sub reader    { $_[0]->{reader}    }
  50 sub writer    { $_[0]->{writer}    }
  51 sub predicate { $_[0]->{predicate} }
  52 sub init_arg  { $_[0]->{init_arg}  }
  53
  54 sub default {
  55     my $self = shift;
  56     if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
  57         return $self->{default}->(shift);
  58     }
  59     $self->{default};
  60 }
  61
  62 sub install_accessors {
  63     my ($self, $class) = @_;
  64     (blessed($class) && $class->isa('Class::MOP::Class'))
  65         || confess "You must pass a Class::MOP::Class instance (or a subclass)";
  66
  67     if ($self->has_accessor()) {
  68         my $accessor = $self->accessor();
  69         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
  70             my ($name, $method) = each %{$accessor};
  71             $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
  72         }
  73         else {
  74             $class->add_method($accessor => Class::MOP::Attribute::Accessor->wrap(sub {
  75                 $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
  76                 $_[0]->{$self->name};
  77             }));
  78         }
  79     }
  80     else {
  81         if ($self->has_reader()) {
  82             my $reader = $self->reader();
  83             if (reftype($reader) && reftype($reader) eq 'HASH') {
  84                 my ($name, $method) = each %{$reader};
  85                 $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
  86             }
  87             else {
  88                 $class->add_method($reader => Class::MOP::Attribute::Accessor->wrap(sub {
  89                     $_[0]->{$self->name};
  90                 }));
  91             }
  92         }
  93         if ($self->has_writer()) {
  94             my $writer = $self->writer();
  95             if (reftype($writer) && reftype($writer) eq 'HASH') {
  96                 my ($name, $method) = each %{$writer};
  97                 $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
  98             }
  99             else {
 100                 $class->add_method($writer => Class::MOP::Attribute::Accessor->wrap(sub {
 101                     $_[0]->{$self->name} = $_[1];
 102                     return;
 103                 }));
 104             }
 105         }
 106     }
 107
 108     if ($self->has_predicate()) {
 109         my $predicate = $self->predicate();
 110         if (reftype($predicate) && reftype($predicate) eq 'HASH') {
 111             my ($name, $method) = each %{$predicate};
 112             $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
 113         }
 114         else {
 115             $class->add_method($predicate => Class::MOP::Attribute::Accessor->wrap(sub {
 116                 defined $_[0]->{$self->name} ? 1 : 0;
 117             }));
 118         }
 119     }
 120 }
 121
 122 sub remove_accessors {
 123     my ($self, $class) = @_;
 124     (blessed($class) && $class->isa('Class::MOP::Class'))
 125         || confess "You must pass a Class::MOP::Class instance (or a subclass)";
 126
 127     if ($self->has_accessor()) {
 128         my $accessor = $self->accessor();
 129         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
 130             ($accessor) = keys %{$accessor};
 131         }
 132         my $method = $class->get_method($accessor);
 133         $class->remove_method($accessor)
 134             if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 135     }
 136     else {
 137         if ($self->has_reader()) {
 138             my $reader = $self->reader();
 139             if (reftype($reader) && reftype($reader) eq 'HASH') {
 140                 ($reader) = keys %{$reader};
 141             }
 142             my $method = $class->get_method($reader);
 143             $class->remove_method($reader)
 144                 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 145         }
 146         if ($self->has_writer()) {
 147             my $writer = $self->writer();
 148             if (reftype($writer) && reftype($writer) eq 'HASH') {
 149                 ($writer) = keys %{$writer};
 150             }
 151             my $method = $class->get_method($writer);
 152             $class->remove_method($writer)
 153                 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 154         }
 155     }
 156
 157     if ($self->has_predicate()) {
 158         my $predicate = $self->predicate();
 159         if (reftype($predicate) && reftype($predicate) eq 'HASH') {
 160             ($predicate) = keys %{$predicate};
 161         }
 162         my $method = $class->get_method($predicate);
 163         $class->remove_method($predicate)
 164             if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 165     }
 166 }
 167
 168 package Class::MOP::Attribute::Accessor;
 169
 170 use strict;
 171 use warnings;
 172
 173 our $VERSION = '0.01';
 174
 175 our @ISA = ('Class::MOP::Method');
 176
 177 1;
 178
 179 __END__
 180
 181 =pod
 182
 183 =head1 NAME
 184
 185 Class::MOP::Attribute - Attribute Meta Object
 186
 187 =head1 SYNOPSIS
 188
 189   Class::MOP::Attribute->new('$foo' => (
 190       accessor => 'foo',        # dual purpose get/set accessor
 191       init_arg => '-foo',       # class->new will look for a -foo key
 192       default  => 'BAR IS BAZ!' # if no -foo key is provided, use this
 193   ));
 194
 195   Class::MOP::Attribute->new('$.bar' => (
 196       reader   => 'bar',        # getter
 197       writer   => 'set_bar',    # setter
 198       init_arg => '-bar',       # class->new will look for a -bar key
 199       # no default value means it is undef
 200   ));
 201
 202 =head1 DESCRIPTION
 203
 204 The Attribute Protocol is almost entirely an invention of this module. This is
 205 because Perl 5 does not have consistent notion of what is an attribute
 206 of a class. There are so many ways in which this is done, and very few
 207 (if any) are discoverable by this module.
 208
 209 So, all that said, this module attempts to inject some order into this
 210 chaos, by introducing a more consistent approach.
 211
 212 =head1 METHODS
 213
 214 =head2 Creation
 215
 216 =over 4
 217
 218 =item B<new ($name, %accessor_description, $class_initialization_arg, $default_value)>
 219
 220 =back
 221
 222 =head2 Informational
 223
 224 =over 4
 225
 226 =item B<name>
 227
 228 =item B<accessor>
 229
 230 =item B<reader>
 231
 232 =item B<writer>
 233
 234 =item B<predicate>
 235
 236 =item B<init_arg>
 237
 238 =item B<default>
 239
 240 =back
 241
 242 =head2 Informational predicates
 243
 244 =over 4
 245
 246 =item B<has_accessor>
 247
 248 Returns true if this attribute uses a get/set accessor, and false
 249 otherwise
 250
 251 =item B<has_reader>
 252
 253 Returns true if this attribute has a reader, and false otherwise
 254
 255 =item B<has_writer>
 256
 257 Returns true if this attribute has a writer, and false otherwise
 258
 259 =item B<has_predicate>
 260
 261 Returns true if this attribute has a predicate, and false otherwise
 262
 263 =item B<has_init_arg>
 264
 265 Returns true if this attribute has a class intialization argument, and
 266 false otherwise
 267
 268 =item B<has_default>
 269
 270 Returns true if this attribute has a default value, and false
 271 otherwise.
 272
 273 =back
 274
 275 =head2 Attribute Accessor generation
 276
 277 =over 4
 278
 279 =item B<install_accessors ($class)>
 280
 281 This allows the attribute to generate and install code for it's own
 282 accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
 283
 284 =item B<remove_accessors ($class)>
 285
 286 This allows the attribute to remove the method for it's own
 287 accessor. This is called by C<Class::MOP::Class::remove_attribute>.
 288
 289 =back
 290
 291 =head2 Introspection
 292
 293 =over 4
 294
 295 =item B<meta>
 296
 297 =back
 298
 299 =head1 AUTHOR
 300
 301 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 302
 303 =head1 COPYRIGHT AND LICENSE
 304
 305 Copyright 2006 by Infinity Interactive, Inc.
 306
 307 L<http://www.iinteractive.com>
 308
 309 This library is free software; you can redistribute it and/or modify
 310 it under the same terms as Perl itself.
 311
 312 =cut