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