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