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