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