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, %options)>
 210
 211 =over 4
 212
 213 =item I<accessor>
 214
 215 =item I<reader>
 216
 217 =item I<writer>
 218
 219 =item I<predicate>
 220
 221 =item I<init_arg>
 222
 223 =item I<default>
 224
 225 =back
 226
 227 =back
 228
 229 =head2 Informational
 230
 231 =over 4
 232
 233 =item B<name>
 234
 235 =item B<accessor>
 236
 237 =item B<reader>
 238
 239 =item B<writer>
 240
 241 =item B<predicate>
 242
 243 =item B<init_arg>
 244
 245 =item B<default>
 246
 247 =back
 248
 249 =head2 Informational predicates
 250
 251 =over 4
 252
 253 =item B<has_accessor>
 254
 255 Returns true if this attribute uses a get/set accessor, and false
 256 otherwise
 257
 258 =item B<has_reader>
 259
 260 Returns true if this attribute has a reader, and false otherwise
 261
 262 =item B<has_writer>
 263
 264 Returns true if this attribute has a writer, and false otherwise
 265
 266 =item B<has_predicate>
 267
 268 Returns true if this attribute has a predicate, and false otherwise
 269
 270 =item B<has_init_arg>
 271
 272 Returns true if this attribute has a class intialization argument, and
 273 false otherwise
 274
 275 =item B<has_default>
 276
 277 Returns true if this attribute has a default value, and false
 278 otherwise.
 279
 280 =back
 281
 282 =head2 Attribute Accessor generation
 283
 284 =over 4
 285
 286 =item B<install_accessors ($class)>
 287
 288 This allows the attribute to generate and install code for it's own
 289 accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
 290
 291 =item B<remove_accessors ($class)>
 292
 293 This allows the attribute to remove the method for it's own
 294 accessor. This is called by C<Class::MOP::Class::remove_attribute>.
 295
 296 =back
 297
 298 =head2 Introspection
 299
 300 =over 4
 301
 302 =item B<meta>
 303
 304 =back
 305
 306 =head1 AUTHOR
 307
 308 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 309
 310 =head1 COPYRIGHT AND LICENSE
 311
 312 Copyright 2006 by Infinity Interactive, Inc.
 313
 314 L<http://www.iinteractive.com>
 315
 316 This library is free software; you can redistribute it and/or modify
 317 it under the same terms as Perl itself.
 318
 319 =cut