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.09';
  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 replaced 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 replaced 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, $meta_instance, $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($instance);
  73     }
  74     $meta_instance->set_slot_value($instance, $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 is_default_a_coderef {
 102     (reftype($_[0]->{default}) && reftype($_[0]->{default}) eq 'CODE')
 103 }
 104
 105 sub default {
 106     my ($self, $instance) = @_;
 107     if ($instance && $self->is_default_a_coderef) {
 108         # if the default is a CODE ref, then
 109         # we pass in the instance and default
 110         # can return a value based on that
 111         # instance. Somewhat crude, but works.
 112         return $self->{default}->($instance);
 113     }
 114     $self->{default};
 115 }
 116
 117 # slots
 118
 119 sub slots { (shift)->name }
 120
 121 # class association
 122
 123 sub attach_to_class {
 124     my ($self, $class) = @_;
 125     (blessed($class) && $class->isa('Class::MOP::Class'))
 126         || confess "You must pass a Class::MOP::Class instance (or a subclass)";
 127     weaken($self->{associated_class} = $class);
 128 }
 129
 130 sub detach_from_class {
 131     my $self = shift;
 132     $self->{associated_class} = undef;
 133 }
 134
 135 ## Slot management
 136
 137 sub set_value {
 138     my ( $self, $instance, $value ) = @_;
 139
 140     Class::MOP::Class->initialize(Scalar::Util::blessed($instance))
 141                      ->get_meta_instance
 142                      ->set_slot_value( $instance, $self->name, $value );
 143 }
 144
 145 sub get_value {
 146     my ( $self, $instance ) = @_;
 147
 148     Class::MOP::Class->initialize(Scalar::Util::blessed($instance))
 149                      ->get_meta_instance
 150                      ->get_slot_value( $instance, $self->name );
 151 }
 152
 153 ## Method generation helpers
 154
 155 sub generate_accessor_method {
 156     my $attr = shift;
 157     return sub {
 158         $attr->set_value( $_[0], $_[1] ) if scalar(@_) == 2;
 159         $attr->get_value( $_[0] );
 160     };
 161 }
 162
 163 sub generate_accessor_method_inline {
 164     my $self          = shift;
 165     my $attr_name     = $self->name;
 166     my $meta_instance = $self->associated_class->instance_metaclass;
 167
 168     my $code = eval 'sub {'
 169         . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')  . ' if scalar(@_) == 2; '
 170         . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
 171     . '}';
 172     confess "Could not generate inline accessor because : $@" if $@;
 173
 174     return $code;
 175 }
 176
 177 sub generate_reader_method {
 178     my $attr = shift;
 179     return sub {
 180         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
 181         $attr->get_value( $_[0] );
 182     };
 183 }
 184
 185 sub generate_reader_method_inline {
 186     my $self          = shift;
 187     my $attr_name     = $self->name;
 188     my $meta_instance = $self->associated_class->instance_metaclass;
 189
 190     my $code = eval 'sub {'
 191         . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
 192         . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
 193     . '}';
 194     confess "Could not generate inline accessor because : $@" if $@;
 195
 196     return $code;
 197 }
 198
 199 sub generate_writer_method {
 200     my $attr = shift;
 201     return sub {
 202         $attr->set_value( $_[0], $_[1] );
 203     };
 204 }
 205
 206 sub generate_writer_method_inline {
 207     my $self          = shift;
 208     my $attr_name     = $self->name;
 209     my $meta_instance = $self->associated_class->instance_metaclass;
 210
 211     my $code = eval 'sub {'
 212         . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')
 213     . '}';
 214     confess "Could not generate inline accessor because : $@" if $@;
 215
 216     return $code;
 217 }
 218
 219 sub generate_predicate_method {
 220     my $self = shift;
 221     my $attr_name  = $self->name;
 222     return sub {
 223         defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
 224                                  ->get_meta_instance
 225                                  ->get_slot_value($_[0], $attr_name) ? 1 : 0;
 226     };
 227 }
 228
 229 sub generate_predicate_method_inline {
 230     my $self          = shift;
 231     my $attr_name     = $self->name;
 232     my $meta_instance = $self->associated_class->instance_metaclass;
 233
 234     my $code = eval 'sub {'
 235         . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") . ' ? 1 : 0'
 236     . '}';
 237     confess "Could not generate inline accessor because : $@" if $@;
 238
 239     return $code;
 240 }
 241
 242 sub process_accessors {
 243     my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
 244     if (reftype($accessor)) {
 245         (reftype($accessor) eq 'HASH')
 246             || confess "bad accessor/reader/writer/predicate format, must be a HASH ref";
 247         my ($name, $method) = %{$accessor};
 248         return ($name, Class::MOP::Attribute::Accessor->wrap($method));
 249     }
 250     else {
 251         my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
 252         my $generator = $self->can('generate_' . $type . '_method' . ($inline_me ? '_inline' : ''));
 253         ($generator)
 254             || confess "There is no method generator for the type='$type'";
 255         if (my $method = $self->$generator($self->name)) {
 256             return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
 257         }
 258         confess "Could not create the '$type' method for " . $self->name . " because : $@";
 259     }
 260 }
 261
 262 sub install_accessors {
 263     my $self   = shift;
 264     my $inline = shift;
 265     my $class  = $self->associated_class;
 266
 267     $class->add_method(
 268         $self->process_accessors('accessor' => $self->accessor(), $inline)
 269     ) if $self->has_accessor();
 270
 271     $class->add_method(
 272         $self->process_accessors('reader' => $self->reader(), $inline)
 273     ) if $self->has_reader();
 274
 275     $class->add_method(
 276         $self->process_accessors('writer' => $self->writer(), $inline)
 277     ) if $self->has_writer();
 278
 279     $class->add_method(
 280         $self->process_accessors('predicate' => $self->predicate(), $inline)
 281     ) if $self->has_predicate();
 282
 283     return;
 284 }
 285
 286 {
 287     my $_remove_accessor = sub {
 288         my ($accessor, $class) = @_;
 289         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
 290             ($accessor) = keys %{$accessor};
 291         }
 292         my $method = $class->get_method($accessor);
 293         $class->remove_method($accessor)
 294             if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
 295     };
 296
 297     sub remove_accessors {
 298         my $self = shift;
 299         $_remove_accessor->($self->accessor(),  $self->associated_class()) if $self->has_accessor();
 300         $_remove_accessor->($self->reader(),    $self->associated_class()) if $self->has_reader();
 301         $_remove_accessor->($self->writer(),    $self->associated_class()) if $self->has_writer();
 302         $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
 303         return;
 304     }
 305
 306 }
 307
 308 package Class::MOP::Attribute::Accessor;
 309
 310 use strict;
 311 use warnings;
 312
 313 use Class::MOP::Method;
 314
 315 our $VERSION = '0.01';
 316
 317 our @ISA = ('Class::MOP::Method');
 318
 319 1;
 320
 321 __END__
 322
 323 =pod
 324
 325 =head1 NAME
 326
 327 Class::MOP::Attribute - Attribute Meta Object
 328
 329 =head1 SYNOPSIS
 330
 331   Class::MOP::Attribute->new('$foo' => (
 332       accessor  => 'foo',        # dual purpose get/set accessor
 333       predicate => 'has_foo'     # predicate check for defined-ness
 334       init_arg  => '-foo',       # class->new will look for a -foo key
 335       default   => 'BAR IS BAZ!' # if no -foo key is provided, use this
 336   ));
 337
 338   Class::MOP::Attribute->new('$.bar' => (
 339       reader    => 'bar',        # getter
 340       writer    => 'set_bar',    # setter
 341       predicate => 'has_bar'     # predicate check for defined-ness
 342       init_arg  => ':bar',       # class->new will look for a :bar key
 343       # no default value means it is undef
 344   ));
 345
 346 =head1 DESCRIPTION
 347
 348 The Attribute Protocol is almost entirely an invention of this module,
 349 and is completely optional to this MOP. This is because Perl 5 does not
 350 have consistent notion of what is an attribute of a class. There are
 351 so many ways in which this is done, and very few (if any) are
 352 easily discoverable by this module.
 353
 354 So, all that said, this module attempts to inject some order into this
 355 chaos, by introducing a consistent API which can be used to create
 356 object attributes.
 357
 358 =head1 METHODS
 359
 360 =head2 Creation
 361
 362 =over 4
 363
 364 =item B<new ($name, ?%options)>
 365
 366 An attribute must (at the very least), have a C<$name>. All other
 367 C<%options> are contained added as key-value pairs. Acceptable keys
 368 are as follows:
 369
 370 =over 4
 371
 372 =item I<init_arg>
 373
 374 This should be a string value representing the expected key in
 375 an initialization hash. For instance, if we have an I<init_arg>
 376 value of C<-foo>, then the following code will Just Work.
 377
 378   MyClass->meta->construct_instance(-foo => "Hello There");
 379
 380 In an init_arg is not assigned, it will automatically use the
 381 value of C<$name>.
 382
 383 =item I<default>
 384
 385 The value of this key is the default value which
 386 C<Class::MOP::Class::construct_instance> will initialize the
 387 attribute to.
 388
 389 B<NOTE:>
 390 If the value is a simple scalar (string or number), then it can
 391 be just passed as is. However, if you wish to initialize it with
 392 a HASH or ARRAY ref, then you need to wrap that inside a CODE
 393 reference, like so:
 394
 395   Class::MOP::Attribute->new('@foo' => (
 396       default => sub { [] },
 397   ));
 398
 399   # or ...
 400
 401   Class::MOP::Attribute->new('%foo' => (
 402       default => sub { {} },
 403   ));
 404
 405 If you wish to initialize an attribute with a CODE reference
 406 itself, then you need to wrap that in a subroutine as well, like
 407 so:
 408
 409   Class::MOP::Attribute->new('&foo' => (
 410       default => sub { sub { print "Hello World" } },
 411   ));
 412
 413 And lastly, if the value of your attribute is dependent upon
 414 some other aspect of the instance structure, then you can take
 415 advantage of the fact that when the I<default> value is a CODE
 416 reference, it is passed the raw (unblessed) instance structure
 417 as it's only argument. So you can do things like this:
 418
 419   Class::MOP::Attribute->new('$object_identity' => (
 420       default => sub { Scalar::Util::refaddr($_[0]) },
 421   ));
 422
 423 This last feature is fairly limited as there is no gurantee of
 424 the order of attribute initializations, so you cannot perform
 425 any kind of dependent initializations. However, if this is
 426 something you need, you could subclass B<Class::MOP::Class> and
 427 this class to acheive it. However, this is currently left as
 428 an exercise to the reader :).
 429
 430 =back
 431
 432 The I<accessor>, I<reader>, I<writer> and I<predicate> keys can
 433 contain either; the name of the method and an appropriate default
 434 one will be generated for you, B<or> a HASH ref containing exactly one
 435 key (which will be used as the name of the method) and one value,
 436 which should contain a CODE reference which will be installed as
 437 the method itself.
 438
 439 =over 4
 440
 441 =item I<accessor>
 442
 443 The I<accessor> is a standard perl-style read/write accessor. It will
 444 return the value of the attribute, and if a value is passed as an argument,
 445 it will assign that value to the attribute.
 446
 447 B<NOTE:>
 448 This method will properly handle the following code, by assigning an
 449 C<undef> value to the attribute.
 450
 451   $object->set_something(undef);
 452
 453 =item I<reader>
 454
 455 This is a basic read-only accessor, it will just return the value of
 456 the attribute.
 457
 458 =item I<writer>
 459
 460 This is a basic write accessor, it accepts a single argument, and
 461 assigns that value to the attribute. This method does not intentially
 462 return a value, however perl will return the result of the last
 463 expression in the subroutine, which returns in this returning the
 464 same value that it was passed.
 465
 466 B<NOTE:>
 467 This method will properly handle the following code, by assigning an
 468 C<undef> value to the attribute.
 469
 470   $object->set_something();
 471
 472 =item I<predicate>
 473
 474 This is a basic test to see if the value of the attribute is not
 475 C<undef>. It will return true (C<1>) if the attribute's value is
 476 defined, and false (C<0>) otherwise.
 477
 478 =back
 479
 480 =item B<clone (%options)>
 481
 482 =item B<initialize_instance_slot ($instance, $params)>
 483
 484 =back
 485
 486 =head2 Value management
 487
 488 =over 4
 489
 490 =item set_value $instance, $value
 491
 492 Set the value without going through the accessor. Note that this may be done to
 493 even attributes with just read only accessors.
 494
 495 =item get_value $instance
 496
 497 Return the value without going through the accessor. Note that this may be done
 498 even to attributes with just write only accessors.
 499
 500 =back
 501
 502 =head2 Informational
 503
 504 These are all basic read-only value accessors for the values
 505 passed into C<new>. I think they are pretty much self-explanitory.
 506
 507 =over 4
 508
 509 =item B<name>
 510
 511 =item B<accessor>
 512
 513 =item B<reader>
 514
 515 =item B<writer>
 516
 517 =item B<predicate>
 518
 519 =item B<init_arg>
 520
 521 =item B<is_default_a_coderef>
 522
 523 =item B<default (?$instance)>
 524
 525 As noted in the documentation for C<new> above, if the I<default>
 526 value is a CODE reference, this accessor will pass a single additional
 527 argument C<$instance> into it and return the value.
 528
 529 =item B<slots>
 530
 531 Returns a list of slots required by the attribute. This is usually
 532 just one, which is the name of the attribute.
 533
 534 =back
 535
 536 =head2 Informational predicates
 537
 538 These are all basic predicate methods for the values passed into C<new>.
 539
 540 =over 4
 541
 542 =item B<has_accessor>
 543
 544 =item B<has_reader>
 545
 546 =item B<has_writer>
 547
 548 =item B<has_predicate>
 549
 550 =item B<has_init_arg>
 551
 552 =item B<has_default>
 553
 554 =back
 555
 556 =head2 Class association
 557
 558 =over 4
 559
 560 =item B<associated_class>
 561
 562 =item B<attach_to_class ($class)>
 563
 564 =item B<detach_from_class>
 565
 566 =item B<slot_name>
 567
 568 =item B<allocate_slots>
 569
 570 =item B<deallocate_slots>
 571
 572 =back
 573
 574 =head2 Attribute Accessor generation
 575
 576 =over 4
 577
 578 =item B<install_accessors>
 579
 580 This allows the attribute to generate and install code for it's own
 581 I<accessor/reader/writer/predicate> methods. This is called by
 582 C<Class::MOP::Class::add_attribute>.
 583
 584 This method will call C<process_accessors> for each of the possible
 585 method types (accessor, reader, writer & predicate).
 586
 587 =item B<process_accessors ($type, $value)>
 588
 589 This takes a C<$type> (accessor, reader, writer or predicate), and
 590 a C<$value> (the value passed into the constructor for each of the
 591 different types). It will then either generate the method itself
 592 (using the C<generate_*_method> methods listed below) or it will
 593 use the custom method passed through the constructor.
 594
 595 =over 4
 596
 597 =item B<generate_accessor_method>
 598
 599 =item B<generate_predicate_method>
 600
 601 =item B<generate_reader_method>
 602
 603 =item B<generate_writer_method>
 604
 605 =back
 606
 607 =over 4
 608
 609 =item B<generate_accessor_method_inline>
 610
 611 =item B<generate_predicate_method_inline>
 612
 613 =item B<generate_reader_method_inline>
 614
 615 =item B<generate_writer_method_inline>
 616
 617 =back
 618
 619 =item B<remove_accessors>
 620
 621 This allows the attribute to remove the method for it's own
 622 I<accessor/reader/writer/predicate>. This is called by
 623 C<Class::MOP::Class::remove_attribute>.
 624
 625 =back
 626
 627 =head2 Introspection
 628
 629 =over 4
 630
 631 =item B<meta>
 632
 633 This will return a B<Class::MOP::Class> instance which is related
 634 to this class.
 635
 636 It should also be noted that B<Class::MOP> will actually bootstrap
 637 this module by installing a number of attribute meta-objects into
 638 it's metaclass. This will allow this class to reap all the benifits
 639 of the MOP when subclassing it.
 640
 641 =back
 642
 643 =head1 AUTHOR
 644
 645 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 646
 647 =head1 COPYRIGHT AND LICENSE
 648
 649 Copyright 2006 by Infinity Interactive, Inc.
 650
 651 L<http://www.iinteractive.com>
 652
 653 This library is free software; you can redistribute it and/or modify
 654 it under the same terms as Perl itself.
 655
 656 =cut
 657