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', 'weaken';
   9
  10 our $VERSION = '0.03';
  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     $options{init_arg} = $name
  34         if not exists $options{init_arg};
  35
  36     bless {
  37         name      => $name,
  38         accessor  => $options{accessor},
  39         reader    => $options{reader},
  40         writer    => $options{writer},
  41         predicate => $options{predicate},
  42         init_arg  => $options{init_arg},
  43         default   => $options{default},
  44         # keep a weakened link to the
  45         # class we are associated with
  46         associated_class => undef,
  47     } => $class;
  48 }
  49
  50 # NOTE:
  51 # this is a primative (and kludgy) clone operation
  52 # for now, it will be repleace in the Class::MOP
  53 # bootstrap with a proper one, however we know
  54 # that this one will work fine for now.
  55 sub clone {
  56     my $self    = shift;
  57     my %options = @_;
  58     (blessed($self))
  59         || confess "Can only clone an instance";
  60     return bless { %{$self}, %options } => blessed($self);
  61 }
  62
  63 # NOTE:
  64 # the next bunch of methods will get bootstrapped
  65 # away in the Class::MOP bootstrapping section
  66
  67 sub name { $_[0]->{name} }
  68
  69 sub associated_class { $_[0]->{associated_class} }
  70
  71 sub has_accessor  { defined($_[0]->{accessor})  ? 1 : 0 }
  72 sub has_reader    { defined($_[0]->{reader})    ? 1 : 0 }
  73 sub has_writer    { defined($_[0]->{writer})    ? 1 : 0 }
  74 sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
  75 sub has_init_arg  { defined($_[0]->{init_arg})  ? 1 : 0 }
  76 sub has_default   { defined($_[0]->{default})   ? 1 : 0 }
  77
  78 sub accessor  { $_[0]->{accessor}  }
  79 sub reader    { $_[0]->{reader}    }
  80 sub writer    { $_[0]->{writer}    }
  81 sub predicate { $_[0]->{predicate} }
  82 sub init_arg  { $_[0]->{init_arg}  }
  83
  84 # end bootstrapped away method section.
  85 # (all methods below here are kept intact)
  86
  87 sub default {
  88     my $self = shift;
  89     if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
  90         # if the default is a CODE ref, then
  91         # we pass in the instance and default
  92         # can return a value based on that
  93         # instance. Somewhat crude, but works.
  94         return $self->{default}->(shift);
  95     }
  96     $self->{default};
  97 }
  98
  99 # class association
 100
 101 sub attach_to_class {
 102     my ($self, $class) = @_;
 103     (blessed($class) && $class->isa('Class::MOP::Class'))
 104         || confess "You must pass a Class::MOP::Class instance (or a subclass)";
 105     weaken($self->{associated_class} = $class);
 106 }
 107
 108 sub detach_from_class {
 109     my $self = shift;
 110     $self->{associated_class} = undef;
 111 }
 112
 113 ## Method generation helpers
 114
 115 sub generate_accessor_method {
 116     my ($self, $attr_name) = @_;
 117     eval qq{sub {
 118         \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
 119         \$_[0]->{'$attr_name'};
 120     }};
 121 }
 122
 123 sub generate_reader_method {
 124     my ($self, $attr_name) = @_;
 125     eval qq{sub {
 126         \$_[0]->{'$attr_name'};
 127     }};
 128 }
 129
 130 sub generate_writer_method {
 131     my ($self, $attr_name) = @_;
 132     eval qq{sub {
 133         \$_[0]->{'$attr_name'} = \$_[1];
 134     }};
 135 }
 136
 137 sub generate_predicate_method {
 138     my ($self, $attr_name) = @_;
 139     eval qq{sub {
 140         defined \$_[0]->{'$attr_name'} ? 1 : 0;
 141     }};
 142 }
 143
 144 sub process_accessors {
 145     my ($self, $type, $accessor) = @_;
 146     if (reftype($accessor) && reftype($accessor) eq 'HASH') {
 147         my ($name, $method) = each %{$accessor};
 148         return ($name, Class::MOP::Attribute::Accessor->wrap($method));
 149     }
 150     else {
 151         my $generator = $self->can('generate_' . $type . '_method');
 152         ($generator)
 153             || confess "There is no method generator for the type='$type'";
 154         if (my $method = $self->$generator($self->name)) {
 155             return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
 156         }
 157         confess "Could not create the '$type' method for " . $self->name . " because : $@";
 158     }
 159 }
 160
 161 sub install_accessors {
 162     my $self  = shift;
 163     my $class = $self->associated_class;
 164
 165     $class->add_method(
 166         $self->process_accessors('accessor' => $self->accessor())
 167     ) if $self->has_accessor();
 168
 169     $class->add_method(
 170         $self->process_accessors('reader' => $self->reader())
 171     ) if $self->has_reader();
 172
 173     $class->add_method(
 174         $self->process_accessors('writer' => $self->writer())
 175     ) if $self->has_writer();
 176
 177     $class->add_method(
 178         $self->process_accessors('predicate' => $self->predicate())
 179     ) if $self->has_predicate();
 180     return;
 181 }
 182
 183 {
 184     my $_remove_accessor = sub {
 185         my ($accessor, $class) = @_;
 186         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
 187             ($accessor) = keys %{$accessor};
 188         }
 189         my $method = $class->get_method($accessor);
 190         $class->remove_method($accessor)
 191             if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 192     };
 193
 194     sub remove_accessors {
 195         my $self = shift;
 196         $_remove_accessor->($self->accessor(),  $self->associated_class()) if $self->has_accessor();
 197         $_remove_accessor->($self->reader(),    $self->associated_class()) if $self->has_reader();
 198         $_remove_accessor->($self->writer(),    $self->associated_class()) if $self->has_writer();
 199         $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
 200         return;
 201     }
 202
 203 }
 204
 205 package Class::MOP::Attribute::Accessor;
 206
 207 use strict;
 208 use warnings;
 209
 210 use Class::MOP::Method;
 211
 212 our $VERSION = '0.01';
 213
 214 our @ISA = ('Class::MOP::Method');
 215
 216 1;
 217
 218 __END__
 219
 220 =pod
 221
 222 =head1 NAME
 223
 224 Class::MOP::Attribute - Attribute Meta Object
 225
 226 =head1 SYNOPSIS
 227
 228   Class::MOP::Attribute->new('$foo' => (
 229       accessor  => 'foo',        # dual purpose get/set accessor
 230       predicate => 'has_foo'     # predicate check for defined-ness
 231       init_arg  => '-foo',       # class->new will look for a -foo key
 232       default   => 'BAR IS BAZ!' # if no -foo key is provided, use this
 233   ));
 234
 235   Class::MOP::Attribute->new('$.bar' => (
 236       reader    => 'bar',        # getter
 237       writer    => 'set_bar',    # setter
 238       predicate => 'has_bar'     # predicate check for defined-ness
 239       init_arg  => ':bar',       # class->new will look for a :bar key
 240       # no default value means it is undef
 241   ));
 242
 243 =head1 DESCRIPTION
 244
 245 The Attribute Protocol is almost entirely an invention of this module,
 246 and is completely optional to this MOP. This is because Perl 5 does not
 247 have consistent notion of what is an attribute of a class. There are
 248 so many ways in which this is done, and very few (if any) are
 249 easily discoverable by this module.
 250
 251 So, all that said, this module attempts to inject some order into this
 252 chaos, by introducing a consistent API which can be used to create
 253 object attributes.
 254
 255 =head1 METHODS
 256
 257 =head2 Creation
 258
 259 =over 4
 260
 261 =item B<new ($name, ?%options)>
 262
 263 An attribute must (at the very least), have a C<$name>. All other
 264 C<%options> are contained added as key-value pairs. Acceptable keys
 265 are as follows:
 266
 267 =item B<clone (%options)>
 268
 269 =over 4
 270
 271 =item I<init_arg>
 272
 273 This should be a string value representing the expected key in
 274 an initialization hash. For instance, if we have an I<init_arg>
 275 value of C<-foo>, then the following code will Just Work.
 276
 277   MyClass->meta->construct_instance(-foo => "Hello There");
 278
 279 In an init_arg is not assigned, it will automatically use the
 280 value of C<$name>.
 281
 282 =item I<default>
 283
 284 The value of this key is the default value which
 285 C<Class::MOP::Class::construct_instance> will initialize the
 286 attribute to.
 287
 288 B<NOTE:>
 289 If the value is a simple scalar (string or number), then it can
 290 be just passed as is. However, if you wish to initialize it with
 291 a HASH or ARRAY ref, then you need to wrap that inside a CODE
 292 reference, like so:
 293
 294   Class::MOP::Attribute->new('@foo' => (
 295       default => sub { [] },
 296   ));
 297
 298   # or ...
 299
 300   Class::MOP::Attribute->new('%foo' => (
 301       default => sub { {} },
 302   ));
 303
 304 If you wish to initialize an attribute with a CODE reference
 305 itself, then you need to wrap that in a subroutine as well, like
 306 so:
 307
 308   Class::MOP::Attribute->new('&foo' => (
 309       default => sub { sub { print "Hello World" } },
 310   ));
 311
 312 And lastly, if the value of your attribute is dependent upon
 313 some other aspect of the instance structure, then you can take
 314 advantage of the fact that when the I<default> value is a CODE
 315 reference, it is passed the raw (unblessed) instance structure
 316 as it's only argument. So you can do things like this:
 317
 318   Class::MOP::Attribute->new('$object_identity' => (
 319       default => sub { Scalar::Util::refaddr($_[0]) },
 320   ));
 321
 322 This last feature is fairly limited as there is no gurantee of
 323 the order of attribute initializations, so you cannot perform
 324 any kind of dependent initializations. However, if this is
 325 something you need, you could subclass B<Class::MOP::Class> and
 326 this class to acheive it. However, this is currently left as
 327 an exercise to the reader :).
 328
 329 =back
 330
 331 The I<accessor>, I<reader>, I<writer> and I<predicate> keys can
 332 contain either; the name of the method and an appropriate default
 333 one will be generated for you, B<or> a HASH ref containing exactly one
 334 key (which will be used as the name of the method) and one value,
 335 which should contain a CODE reference which will be installed as
 336 the method itself.
 337
 338 =over 4
 339
 340 =item I<accessor>
 341
 342 The I<accessor> is a standard perl-style read/write accessor. It will
 343 return the value of the attribute, and if a value is passed as an argument,
 344 it will assign that value to the attribute.
 345
 346 B<NOTE:>
 347 This method will properly handle the following code, by assigning an
 348 C<undef> value to the attribute.
 349
 350   $object->set_something(undef);
 351
 352 =item I<reader>
 353
 354 This is a basic read-only accessor, it will just return the value of
 355 the attribute.
 356
 357 =item I<writer>
 358
 359 This is a basic write accessor, it accepts a single argument, and
 360 assigns that value to the attribute. This method does not intentially
 361 return a value, however perl will return the result of the last
 362 expression in the subroutine, which returns in this returning the
 363 same value that it was passed.
 364
 365 B<NOTE:>
 366 This method will properly handle the following code, by assigning an
 367 C<undef> value to the attribute.
 368
 369   $object->set_something();
 370
 371 =item I<predicate>
 372
 373 This is a basic test to see if the value of the attribute is not
 374 C<undef>. It will return true (C<1>) if the attribute's value is
 375 defined, and false (C<0>) otherwise.
 376
 377 =back
 378
 379 =back
 380
 381 =head2 Informational
 382
 383 These are all basic read-only value accessors for the values
 384 passed into C<new>. I think they are pretty much self-explanitory.
 385
 386 =over 4
 387
 388 =item B<name>
 389
 390 =item B<accessor>
 391
 392 =item B<reader>
 393
 394 =item B<writer>
 395
 396 =item B<predicate>
 397
 398 =item B<init_arg>
 399
 400 =item B<default (?$instance)>
 401
 402 As noted in the documentation for C<new> above, if the I<default>
 403 value is a CODE reference, this accessor will pass a single additional
 404 argument C<$instance> into it and return the value.
 405
 406 =back
 407
 408 =head2 Informational predicates
 409
 410 These are all basic predicate methods for the values passed into C<new>.
 411
 412 =over 4
 413
 414 =item B<has_accessor>
 415
 416 =item B<has_reader>
 417
 418 =item B<has_writer>
 419
 420 =item B<has_predicate>
 421
 422 =item B<has_init_arg>
 423
 424 =item B<has_default>
 425
 426 =back
 427
 428 =head2 Class association
 429
 430 =over 4
 431
 432 =item B<associated_class>
 433
 434 =item B<attach_to_class ($class)>
 435
 436 =item B<detach_from_class>
 437
 438 =back
 439
 440 =head2 Attribute Accessor generation
 441
 442 =over 4
 443
 444 =item B<install_accessors>
 445
 446 This allows the attribute to generate and install code for it's own
 447 I<accessor/reader/writer/predicate> methods. This is called by
 448 C<Class::MOP::Class::add_attribute>.
 449
 450 This method will call C<process_accessors> for each of the possible
 451 method types (accessor, reader, writer & predicate).
 452
 453 =item B<process_accessors ($type, $value)>
 454
 455 This takes a C<$type> (accessor, reader, writer or predicate), and
 456 a C<$value> (the value passed into the constructor for each of the
 457 different types). It will then either generate the method itself
 458 (using the C<generate_*_method> methods listed below) or it will
 459 use the custom method passed through the constructor.
 460
 461 =over 4
 462
 463 =item B<generate_accessor_method ($attr_name)>
 464
 465 =item B<generate_predicate_method ($attr_name)>
 466
 467 =item B<generate_reader_method ($attr_name)>
 468
 469 =item B<generate_writer_method ($attr_name)>
 470
 471 =back
 472
 473 =item B<remove_accessors>
 474
 475 This allows the attribute to remove the method for it's own
 476 I<accessor/reader/writer/predicate>. This is called by
 477 C<Class::MOP::Class::remove_attribute>.
 478
 479 =back
 480
 481 =head2 Introspection
 482
 483 =over 4
 484
 485 =item B<meta>
 486
 487 This will return a B<Class::MOP::Class> instance which is related
 488 to this class.
 489
 490 It should also be noted that B<Class::MOP> will actually bootstrap
 491 this module by installing a number of attribute meta-objects into
 492 it's metaclass. This will allow this class to reap all the benifits
 493 of the MOP when subclassing it.
 494
 495 =back
 496
 497 =head1 AUTHOR
 498
 499 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 500
 501 =head1 COPYRIGHT AND LICENSE
 502
 503 Copyright 2006 by Infinity Interactive, Inc.
 504
 505 L<http://www.iinteractive.com>
 506
 507 This library is free software; you can redistribute it and/or modify
 508 it under the same terms as Perl itself.
 509
 510 =cut