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' => qq{sub {
  83                 \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
  84                 \$_[0]->{'$attr_name'};
  85             }},
  86             'reader' => qq{sub {
  87                 \$_[0]->{'$attr_name'};
  88             }},
  89             'writer' => qq{sub {
  90                 \$_[0]->{'$attr_name'} = \$_[1];
  91                 return;
  92             }},
  93             'predicate' => qq{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             my $method = eval $ACCESSOR_TEMPLATES{$type};
 104             confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
 105             return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
 106         }
 107     };
 108
 109     sub install_accessors {
 110         my ($self, $class) = @_;
 111         (blessed($class) && $class->isa('Class::MOP::Class'))
 112             || confess "You must pass a Class::MOP::Class instance (or a subclass)";
 113         $class->add_method(
 114             $_inspect_accessor->($self->name, 'accessor' => $self->accessor())
 115         ) if $self->has_accessor();
 116
 117         $class->add_method(
 118             $_inspect_accessor->($self->name, 'reader' => $self->reader())
 119         ) if $self->has_reader();
 120
 121         $class->add_method(
 122             $_inspect_accessor->($self->name, 'writer' => $self->writer())
 123         ) if $self->has_writer();
 124
 125         $class->add_method(
 126             $_inspect_accessor->($self->name, 'predicate' => $self->predicate())
 127         ) if $self->has_predicate();
 128         return;
 129     }
 130
 131 }
 132
 133 {
 134     my $_remove_accessor = sub {
 135         my ($accessor, $class) = @_;
 136         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
 137             ($accessor) = keys %{$accessor};
 138         }
 139         my $method = $class->get_method($accessor);
 140         $class->remove_method($accessor)
 141             if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 142     };
 143
 144     sub remove_accessors {
 145         my ($self, $class) = @_;
 146         (blessed($class) && $class->isa('Class::MOP::Class'))
 147             || confess "You must pass a Class::MOP::Class instance (or a subclass)";
 148         $_remove_accessor->($self->accessor(),  $class) if $self->has_accessor();
 149         $_remove_accessor->($self->reader(),    $class) if $self->has_reader();
 150         $_remove_accessor->($self->writer(),    $class) if $self->has_writer();
 151         $_remove_accessor->($self->predicate(), $class) if $self->has_predicate();
 152         return;
 153     }
 154
 155 }
 156
 157 package Class::MOP::Attribute::Accessor;
 158
 159 use strict;
 160 use warnings;
 161
 162 use Class::MOP::Method;
 163
 164 our $VERSION = '0.01';
 165
 166 our @ISA = ('Class::MOP::Method');
 167
 168 1;
 169
 170 __END__
 171
 172 =pod
 173
 174 =head1 NAME
 175
 176 Class::MOP::Attribute - Attribute Meta Object
 177
 178 =head1 SYNOPSIS
 179
 180   Class::MOP::Attribute->new('$foo' => (
 181       accessor => 'foo',        # dual purpose get/set accessor
 182       init_arg => '-foo',       # class->new will look for a -foo key
 183       default  => 'BAR IS BAZ!' # if no -foo key is provided, use this
 184   ));
 185
 186   Class::MOP::Attribute->new('$.bar' => (
 187       reader   => 'bar',        # getter
 188       writer   => 'set_bar',    # setter
 189       init_arg => '-bar',       # class->new will look for a -bar key
 190       # no default value means it is undef
 191   ));
 192
 193 =head1 DESCRIPTION
 194
 195 The Attribute Protocol is almost entirely an invention of this module. This is
 196 because Perl 5 does not have consistent notion of what is an attribute
 197 of a class. There are so many ways in which this is done, and very few
 198 (if any) are discoverable by this module.
 199
 200 So, all that said, this module attempts to inject some order into this
 201 chaos, by introducing a more consistent approach.
 202
 203 =head1 METHODS
 204
 205 =head2 Creation
 206
 207 =over 4
 208
 209 =item B<new ($name, %accessor_description, $class_initialization_arg, $default_value)>
 210
 211 =back
 212
 213 =head2 Informational
 214
 215 =over 4
 216
 217 =item B<name>
 218
 219 =item B<accessor>
 220
 221 =item B<reader>
 222
 223 =item B<writer>
 224
 225 =item B<predicate>
 226
 227 =item B<init_arg>
 228
 229 =item B<default>
 230
 231 =back
 232
 233 =head2 Informational predicates
 234
 235 =over 4
 236
 237 =item B<has_accessor>
 238
 239 Returns true if this attribute uses a get/set accessor, and false
 240 otherwise
 241
 242 =item B<has_reader>
 243
 244 Returns true if this attribute has a reader, and false otherwise
 245
 246 =item B<has_writer>
 247
 248 Returns true if this attribute has a writer, and false otherwise
 249
 250 =item B<has_predicate>
 251
 252 Returns true if this attribute has a predicate, and false otherwise
 253
 254 =item B<has_init_arg>
 255
 256 Returns true if this attribute has a class intialization argument, and
 257 false otherwise
 258
 259 =item B<has_default>
 260
 261 Returns true if this attribute has a default value, and false
 262 otherwise.
 263
 264 =back
 265
 266 =head2 Attribute Accessor generation
 267
 268 =over 4
 269
 270 =item B<install_accessors ($class)>
 271
 272 This allows the attribute to generate and install code for it's own
 273 accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
 274
 275 =item B<remove_accessors ($class)>
 276
 277 This allows the attribute to remove the method for it's own
 278 accessor. This is called by C<Class::MOP::Class::remove_attribute>.
 279
 280 =back
 281
 282 =head2 Introspection
 283
 284 =over 4
 285
 286 =item B<meta>
 287
 288 =back
 289
 290 =head1 AUTHOR
 291
 292 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 293
 294 =head1 COPYRIGHT AND LICENSE
 295
 296 Copyright 2006 by Infinity Interactive, Inc.
 297
 298 L<http://www.iinteractive.com>
 299
 300 This library is free software; you can redistribute it and/or modify
 301 it under the same terms as Perl itself.
 302
 303 =cut