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             }},
  92             'predicate' => qq{sub {
  93                 defined \$_[0]->{'$attr_name'} ? 1 : 0;
  94             }}
  95         );
  96
  97         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
  98             my ($name, $method) = each %{$accessor};
  99             return ($name, Class::MOP::Attribute::Accessor->wrap($method));
 100         }
 101         else {
 102             my $method = eval $ACCESSOR_TEMPLATES{$type};
 103             confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
 104             return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
 105         }
 106     };
 107
 108     sub install_accessors {
 109         my ($self, $class) = @_;
 110         (blessed($class) && $class->isa('Class::MOP::Class'))
 111             || confess "You must pass a Class::MOP::Class instance (or a subclass)";
 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         return;
 128     }
 129
 130 }
 131
 132 {
 133     my $_remove_accessor = sub {
 134         my ($accessor, $class) = @_;
 135         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
 136             ($accessor) = keys %{$accessor};
 137         }
 138         my $method = $class->get_method($accessor);
 139         $class->remove_method($accessor)
 140             if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 141     };
 142
 143     sub remove_accessors {
 144         my ($self, $class) = @_;
 145         (blessed($class) && $class->isa('Class::MOP::Class'))
 146             || confess "You must pass a Class::MOP::Class instance (or a subclass)";
 147         $_remove_accessor->($self->accessor(),  $class) if $self->has_accessor();
 148         $_remove_accessor->($self->reader(),    $class) if $self->has_reader();
 149         $_remove_accessor->($self->writer(),    $class) if $self->has_writer();
 150         $_remove_accessor->($self->predicate(), $class) if $self->has_predicate();
 151         return;
 152     }
 153
 154 }
 155
 156 package Class::MOP::Attribute::Accessor;
 157
 158 use strict;
 159 use warnings;
 160
 161 use Class::MOP::Method;
 162
 163 our $VERSION = '0.01';
 164
 165 our @ISA = ('Class::MOP::Method');
 166
 167 1;
 168
 169 __END__
 170
 171 =pod
 172
 173 =head1 NAME
 174
 175 Class::MOP::Attribute - Attribute Meta Object
 176
 177 =head1 SYNOPSIS
 178
 179   Class::MOP::Attribute->new('$foo' => (
 180       accessor  => 'foo',        # dual purpose get/set accessor
 181       predicate => 'has_foo'     # predicate check for defined-ness
 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       predicate => 'has_bar'     # predicate check for defined-ness
 190       init_arg  => ':bar',       # class->new will look for a :bar key
 191       # no default value means it is undef
 192   ));
 193
 194 =head1 DESCRIPTION
 195
 196 The Attribute Protocol is almost entirely an invention of this module,
 197 and is completely optional to this MOP. This is because Perl 5 does not
 198 have consistent notion of what is an attribute of a class. There are
 199 so many ways in which this is done, and very few (if any) are
 200 easily discoverable by this module.
 201
 202 So, all that said, this module attempts to inject some order into this
 203 chaos, by introducing a consistent API which can be used to create
 204 object attributes.
 205
 206 =head1 METHODS
 207
 208 =head2 Creation
 209
 210 =over 4
 211
 212 =item B<new ($name, ?%options)>
 213
 214 An attribute must (at the very least), have a C<$name>. All other
 215 C<%options> are contained added as key-valeue pairs. Acceptable keys
 216 are as follows:
 217
 218 =over 4
 219
 220 =item I<init_arg>
 221
 222 This should be a string value representing the expected key in
 223 an initialization hash. For instance, if we have an I<init_arg>
 224 value of C<-foo>, then the following code will Just Work.
 225
 226   MyClass->meta->construct_instance(-foo => "Hello There");
 227
 228 =item I<default>
 229
 230 The value of this key is the default value which
 231 C<Class::MOP::Class::construct_instance> will initialize the
 232 attribute to.
 233
 234 B<NOTE:>
 235 If the value is a simple scalar (string or number), then it can
 236 be just passed as is. However, if you wish to initialize it with
 237 a HASH or ARRAY ref, then you need to wrap that inside a CODE
 238 reference, like so:
 239
 240   Class::MOP::Attribute->new('@foo' => (
 241       default => sub { [] },
 242   ));
 243
 244   # or ...
 245
 246   Class::MOP::Attribute->new('%foo' => (
 247       default => sub { {} },
 248   ));
 249
 250 If you wish to initialize an attribute with a CODE reference
 251 itself, then you need to wrap that in a subroutine as well, like
 252 so:
 253
 254   Class::MOP::Attribute->new('&foo' => (
 255       default => sub { sub { print "Hello World" } },
 256   ));
 257
 258 And lastly, if the value of your attribute is dependent upon
 259 some other aspect of the instance structure, then you can take
 260 advantage of the fact that when the I<default> value is a CODE
 261 reference, it is passed the raw (unblessed) instance structure
 262 as it's only argument. So you can do things like this:
 263
 264   Class::MOP::Attribute->new('$object_identity' => (
 265       default => sub { Scalar::Util::refaddr($_[0]) },
 266   ));
 267
 268 This last feature is fairly limited as there is no gurantee of
 269 the order of attribute initializations, so you cannot perform
 270 any kind of dependent initializations. However, if this is
 271 something you need, you could subclass B<Class::MOP::Class> and
 272 this class to acheive it. However, this is currently left as
 273 an exercise to the reader :).
 274
 275 =back
 276
 277 This I<accessor>, I<reader>, I<writer> and I<predicate> keys can
 278 contain either; the name of the method and an appropriate default
 279 one will be generated for you, B<or> a HASH ref containing exactly one
 280 key (which will be used as the name of the method) and one value,
 281 which should contain a CODE reference which will be installed as
 282 the method itself.
 283
 284 =over 4
 285
 286 =item I<accessor>
 287
 288 The I<accessor> is a standard perl-style read/write accessor. It will
 289 return the value of the attribute, and if a value is passed as an argument,
 290 it will assign that value to the attribute.
 291
 292 B<NOTE:>
 293 This method will properly handle the following code, by assigning an
 294 C<undef> value to the attribute.
 295
 296   $object->set_something(undef);
 297
 298 =item I<reader>
 299
 300 This is a basic read-only accessor, it will just return the value of
 301 the attribute.
 302
 303 =item I<writer>
 304
 305 This is a basic write accessor, it accepts a single argument, and
 306 assigns that value to the attribute. This method does not intentially
 307 return a value, however perl will return the result of the last
 308 expression in the subroutine, which returns in this returning the
 309 same value that it was passed.
 310
 311 B<NOTE:>
 312 This method will properly handle the following code, by assigning an
 313 C<undef> value to the attribute.
 314
 315   $object->set_something();
 316
 317 =item I<predicate>
 318
 319 This is a basic test to see if the value of the attribute is not
 320 C<undef>. It will return true (C<1>) if the attribute's value is
 321 defined, and false (C<0>) otherwise.
 322
 323 =back
 324
 325 =back
 326
 327 =head2 Informational
 328
 329 These are all basic read-only value accessors for the values
 330 passed into C<new>. I think they are pretty much self-explanitory.
 331
 332 =over 4
 333
 334 =item B<name>
 335
 336 =item B<accessor>
 337
 338 =item B<reader>
 339
 340 =item B<writer>
 341
 342 =item B<predicate>
 343
 344 =item B<init_arg>
 345
 346 =item B<default (?$instance)>
 347
 348 As noted in the documentation for C<new> above, if the I<default>
 349 value is a CODE reference, this accessor will pass a single additional
 350 argument C<$instance> into it and return the value.
 351
 352 =back
 353
 354 =head2 Informational predicates
 355
 356 These are all basic predicate methodfor the values passed into C<new>.
 357
 358 =over 4
 359
 360 =item B<has_accessor>
 361
 362 =item B<has_reader>
 363
 364 =item B<has_writer>
 365
 366 =item B<has_predicate>
 367
 368 =item B<has_init_arg>
 369
 370 =item B<has_default>
 371
 372 =back
 373
 374 =head2 Attribute Accessor generation
 375
 376 =over 4
 377
 378 =item B<install_accessors ($class)>
 379
 380 This allows the attribute to generate and install code for it's own
 381 accessor/reader/writer/predicate methods. This is called by
 382 C<Class::MOP::Class::add_attribute>.
 383
 384 =item B<remove_accessors ($class)>
 385
 386 This allows the attribute to remove the method for it's own
 387 accessor/reader/writer/predicate. This is called by
 388 C<Class::MOP::Class::remove_attribute>.
 389
 390 =back
 391
 392 =head2 Introspection
 393
 394 =over 4
 395
 396 =item B<meta>
 397
 398 This will return a B<Class::MOP::Class> instance which is related
 399 to this class.
 400
 401 It should also be noted that B<Class::MOP> will actually bootstrap
 402 this module by installing a number of attribute meta-objects into
 403 it's metaclass. This will allow this class to reap all the benifits
 404 of the MOP when subclassing it.
 405
 406 =back
 407
 408 =head1 AUTHOR
 409
 410 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 411
 412 =head1 COPYRIGHT AND LICENSE
 413
 414 Copyright 2006 by Infinity Interactive, Inc.
 415
 416 L<http://www.iinteractive.com>
 417
 418 This library is free software; you can redistribute it and/or modify
 419 it under the same terms as Perl itself.
 420
 421 =cut