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