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';
   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         init_arg => $options{init_arg},
  34         default  => $options{default}
  35     } => $class;
  36 }
  37
  38 sub name         { (shift)->{name}             }
  39
  40 sub has_accessor { (shift)->{accessor} ? 1 : 0 }
  41 sub accessor     { (shift)->{accessor}         }
  42
  43 sub has_reader   { (shift)->{reader}   ? 1 : 0 }
  44 sub reader       { (shift)->{reader}           }
  45
  46 sub has_writer   { (shift)->{writer}   ? 1 : 0 }
  47 sub writer       { (shift)->{writer}           }
  48
  49 sub has_init_arg { (shift)->{init_arg} ? 1 : 0 }
  50 sub init_arg     { (shift)->{init_arg}         }
  51
  52 sub has_default  { (shift)->{default}  ? 1 : 0 }
  53 sub default      { (shift)->{default}          }
  54
  55 sub install_accessors {
  56     my ($self, $class) = @_;
  57     (blessed($class) && $class->isa('Class::MOP::Class'))
  58         || confess "You must pass a Class::MOP::Class instance (or a subclass)";
  59
  60     if ($self->has_accessor()) {
  61         $class->add_method($self->accessor() => Class::MOP::Attribute::Accessor->wrap(sub {
  62             $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
  63             $_[0]->{$self->name};
  64         }));
  65     }
  66     else {
  67         if ($self->has_reader()) {
  68             $class->add_method($self->reader() => Class::MOP::Attribute::Accessor->wrap(sub {
  69                 $_[0]->{$self->name};
  70             }));
  71         }
  72         if ($self->has_writer()) {
  73             $class->add_method($self->writer() => Class::MOP::Attribute::Accessor->wrap(sub {
  74                 $_[0]->{$self->name} = $_[1];
  75                 return;
  76             }));
  77         }
  78     }
  79 }
  80
  81 sub remove_accessors {
  82     my ($self, $class) = @_;
  83     (blessed($class) && $class->isa('Class::MOP::Class'))
  84         || confess "You must pass a Class::MOP::Class instance (or a subclass)";
  85
  86     if ($self->has_accessor()) {
  87         my $method = $class->get_method($self->accessor);
  88         $class->remove_method($self->accessor)
  89             if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
  90     }
  91     else {
  92         if ($self->has_reader()) {
  93             my $method = $class->get_method($self->reader);
  94             $class->remove_method($self->reader)
  95                 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
  96         }
  97         if ($self->has_writer()) {
  98             my $method = $class->get_method($self->writer);
  99             $class->remove_method($self->writer)
 100                 if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 101         }
 102     }
 103 }
 104
 105 package Class::MOP::Attribute::Accessor;
 106
 107 use strict;
 108 use warnings;
 109
 110 our $VERSION = '0.01';
 111
 112 our @ISA = ('Class::MOP::Method');
 113
 114 1;
 115
 116 __END__
 117
 118 =pod
 119
 120 =head1 NAME
 121
 122 Class::MOP::Attribute - Attribute Meta Object
 123
 124 =head1 SYNOPSIS
 125
 126   Class::MOP::Attribute->new('$foo' => (
 127       accessor => 'foo',        # dual purpose get/set accessor
 128       init_arg => '-foo',       # class->new will look for a -foo key
 129       default  => 'BAR IS BAZ!' # if no -foo key is provided, use this
 130   ));
 131
 132   Class::MOP::Attribute->new('$.bar' => (
 133       reader   => 'bar',        # getter
 134       writer   => 'set_bar',    # setter
 135       init_arg => '-bar',       # class->new will look for a -bar key
 136       # no default value means it is undef
 137   ));
 138
 139 =head1 DESCRIPTION
 140
 141 The Attribute Protocol is almost entirely an invention of this module. This is
 142 because Perl 5 does not have consistent notion of what is an attribute
 143 of a class. There are so many ways in which this is done, and very few
 144 (if any) are discoverable by this module.
 145
 146 So, all that said, this module attempts to inject some order into this
 147 chaos, by introducing a more consistent approach.
 148
 149 =head1 METHODS
 150
 151 =head2 Creation
 152
 153 =over 4
 154
 155 =item B<new ($name, %accessor_description, $class_initialization_arg, $default_value)>
 156
 157 =back
 158
 159 =head2 Informational
 160
 161 =over 4
 162
 163 =item B<name>
 164
 165 =item B<accessor>
 166
 167 =item B<reader>
 168
 169 =item B<writer>
 170
 171 =item B<init_arg>
 172
 173 =item B<default>
 174
 175 =back
 176
 177 =head2 Informational predicates
 178
 179 =over 4
 180
 181 =item B<has_accessor>
 182
 183 Returns true if this attribute uses a get/set accessor, and false
 184 otherwise
 185
 186 =item B<has_reader>
 187
 188 Returns true if this attribute has a reader, and false otherwise
 189
 190 =item B<has_writer>
 191
 192 Returns true if this attribute has a writer, and false otherwise
 193
 194 =item B<has_init_arg>
 195
 196 Returns true if this attribute has a class intialization argument, and
 197 false otherwise
 198
 199 =item B<has_default>
 200
 201 Returns true if this attribute has a default value, and false
 202 otherwise.
 203
 204 =back
 205
 206 =head2 Attribute Accessor generation
 207
 208 =over 4
 209
 210 =item B<install_accessors ($class)>
 211
 212 This allows the attribute to generate and install code for it's own
 213 accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
 214
 215 =item B<remove_accessors ($class)>
 216
 217 This allows the attribute to remove the method for it's own
 218 accessor. This is called by C<Class::MOP::Class::remove_attribute>.
 219
 220 =back
 221
 222 =head2 Introspection
 223
 224 =over 4
 225
 226 =item B<meta>
 227
 228 =back
 229
 230 =head1 AUTHOR
 231
 232 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 233
 234 =head1 COPYRIGHT AND LICENSE
 235
 236 Copyright 2006 by Infinity Interactive, Inc.
 237
 238 L<http://www.iinteractive.com>
 239
 240 This library is free software; you can redistribute it and/or modify
 241 it under the same terms as Perl itself.
 242
 243 =cut