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     (reftype($_[0]->{default}) && reftype($_[0]->{default}) eq 'CODE')
 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.01';
 353
 354 our @ISA = ('Class::MOP::Method');
 355
 356 1;
 357
 358 __END__
 359
 360 =pod
 361
 362 =head1 NAME
 363
 364 Class::MOP::Attribute - Attribute Meta Object
 365
 366 =head1 SYNOPSIS
 367
 368   Class::MOP::Attribute->new('$foo' => (
 369       accessor  => 'foo',        # dual purpose get/set accessor
 370       predicate => 'has_foo'     # predicate check for defined-ness
 371       init_arg  => '-foo',       # class->new will look for a -foo key
 372       default   => 'BAR IS BAZ!' # if no -foo key is provided, use this
 373   ));
 374
 375   Class::MOP::Attribute->new('$.bar' => (
 376       reader    => 'bar',        # getter
 377       writer    => 'set_bar',    # setter
 378       predicate => 'has_bar'     # predicate check for defined-ness
 379       init_arg  => ':bar',       # class->new will look for a :bar key
 380       # no default value means it is undef
 381   ));
 382
 383 =head1 DESCRIPTION
 384
 385 The Attribute Protocol is almost entirely an invention of this module,
 386 and is completely optional to this MOP. This is because Perl 5 does not
 387 have consistent notion of what is an attribute of a class. There are
 388 so many ways in which this is done, and very few (if any) are
 389 easily discoverable by this module.
 390
 391 So, all that said, this module attempts to inject some order into this
 392 chaos, by introducing a consistent API which can be used to create
 393 object attributes.
 394
 395 =head1 METHODS
 396
 397 =head2 Creation
 398
 399 =over 4
 400
 401 =item B<new ($name, ?%options)>
 402
 403 An attribute must (at the very least), have a C<$name>. All other
 404 C<%options> are contained added as key-value pairs. Acceptable keys
 405 are as follows:
 406
 407 =over 4
 408
 409 =item I<init_arg>
 410
 411 This should be a string value representing the expected key in
 412 an initialization hash. For instance, if we have an I<init_arg>
 413 value of C<-foo>, then the following code will Just Work.
 414
 415   MyClass->meta->construct_instance(-foo => "Hello There");
 416
 417 In an init_arg is not assigned, it will automatically use the
 418 value of C<$name>.
 419
 420 =item I<default>
 421
 422 The value of this key is the default value which
 423 C<Class::MOP::Class::construct_instance> will initialize the
 424 attribute to.
 425
 426 B<NOTE:>
 427 If the value is a simple scalar (string or number), then it can
 428 be just passed as is. However, if you wish to initialize it with
 429 a HASH or ARRAY ref, then you need to wrap that inside a CODE
 430 reference, like so:
 431
 432   Class::MOP::Attribute->new('@foo' => (
 433       default => sub { [] },
 434   ));
 435
 436   # or ...
 437
 438   Class::MOP::Attribute->new('%foo' => (
 439       default => sub { {} },
 440   ));
 441
 442 If you wish to initialize an attribute with a CODE reference
 443 itself, then you need to wrap that in a subroutine as well, like
 444 so:
 445
 446   Class::MOP::Attribute->new('&foo' => (
 447       default => sub { sub { print "Hello World" } },
 448   ));
 449
 450 And lastly, if the value of your attribute is dependent upon
 451 some other aspect of the instance structure, then you can take
 452 advantage of the fact that when the I<default> value is a CODE
 453 reference, it is passed the raw (unblessed) instance structure
 454 as it's only argument. So you can do things like this:
 455
 456   Class::MOP::Attribute->new('$object_identity' => (
 457       default => sub { Scalar::Util::refaddr($_[0]) },
 458   ));
 459
 460 This last feature is fairly limited as there is no gurantee of
 461 the order of attribute initializations, so you cannot perform
 462 any kind of dependent initializations. However, if this is
 463 something you need, you could subclass B<Class::MOP::Class> and
 464 this class to acheive it. However, this is currently left as
 465 an exercise to the reader :).
 466
 467 =back
 468
 469 The I<accessor>, I<reader>, I<writer>, I<predicate> and I<clearer> keys can
 470 contain either; the name of the method and an appropriate default one will be
 471 generated for you, B<or> a HASH ref containing exactly one key (which will be
 472 used as the name of the method) and one value, which should contain a CODE
 473 reference which will be installed as the method itself.
 474
 475 =over 4
 476
 477 =item I<accessor>
 478
 479 The I<accessor> is a standard perl-style read/write accessor. It will
 480 return the value of the attribute, and if a value is passed as an argument,
 481 it will assign that value to the attribute.
 482
 483 B<NOTE:>
 484 This method will properly handle the following code, by assigning an
 485 C<undef> value to the attribute.
 486
 487   $object->set_something(undef);
 488
 489 =item I<reader>
 490
 491 This is a basic read-only accessor, it will just return the value of
 492 the attribute.
 493
 494 =item I<writer>
 495
 496 This is a basic write accessor, it accepts a single argument, and
 497 assigns that value to the attribute. This method does not intentially
 498 return a value, however perl will return the result of the last
 499 expression in the subroutine, which returns in this returning the
 500 same value that it was passed.
 501
 502 B<NOTE:>
 503 This method will properly handle the following code, by assigning an
 504 C<undef> value to the attribute.
 505
 506   $object->set_something();
 507
 508 =item I<predicate>
 509
 510 This is a basic test to see if the value of the attribute is not
 511 C<undef>. It will return true (C<1>) if the attribute's value is
 512 defined, and false (C<0>) otherwise.
 513
 514 =item I<clearer>
 515
 516 This is the a method that will uninitialize the attr, reverting lazy values
 517 back to their "unfulfilled" state.
 518
 519 =back
 520
 521 =item B<clone (%options)>
 522
 523 =item B<initialize_instance_slot ($instance, $params)>
 524
 525 =back
 526
 527 =head2 Value management
 528
 529 =over 4
 530
 531 =item set_value $instance, $value
 532
 533 Set the value without going through the accessor. Note that this may be done to
 534 even attributes with just read only accessors.
 535
 536 =item get_value $instance
 537
 538 Return the value without going through the accessor. Note that this may be done
 539 even to attributes with just write only accessors.
 540
 541 =back
 542
 543 =head2 Informational
 544
 545 These are all basic read-only value accessors for the values
 546 passed into C<new>. I think they are pretty much self-explanitory.
 547
 548 =over 4
 549
 550 =item B<name>
 551
 552 =item B<accessor>
 553
 554 =item B<reader>
 555
 556 =item B<writer>
 557
 558 =item B<predicate>
 559
 560 =item B<clearer>
 561
 562 =item B<init_arg>
 563
 564 =item B<is_default_a_coderef>
 565
 566 =item B<default (?$instance)>
 567
 568 As noted in the documentation for C<new> above, if the I<default>
 569 value is a CODE reference, this accessor will pass a single additional
 570 argument C<$instance> into it and return the value.
 571
 572 =item B<slots>
 573
 574 Returns a list of slots required by the attribute. This is usually
 575 just one, which is the name of the attribute.
 576
 577 =back
 578
 579 =head2 Informational predicates
 580
 581 These are all basic predicate methods for the values passed into C<new>.
 582
 583 =over 4
 584
 585 =item B<has_accessor>
 586
 587 =item B<has_reader>
 588
 589 =item B<has_writer>
 590
 591 =item B<has_predicate>
 592
 593 =item B<has_clearer>
 594
 595 =item B<has_init_arg>
 596
 597 =item B<has_default>
 598
 599 =back
 600
 601 =head2 Class association
 602
 603 =over 4
 604
 605 =item B<associated_class>
 606
 607 =item B<attach_to_class ($class)>
 608
 609 =item B<detach_from_class>
 610
 611 =item B<slot_name>
 612
 613 =item B<allocate_slots>
 614
 615 =item B<deallocate_slots>
 616
 617 =back
 618
 619 =head2 Attribute Accessor generation
 620
 621 =over 4
 622
 623 =item B<install_accessors>
 624
 625 This allows the attribute to generate and install code for it's own
 626 I<accessor/reader/writer/predicate> methods. This is called by
 627 C<Class::MOP::Class::add_attribute>.
 628
 629 This method will call C<process_accessors> for each of the possible
 630 method types (accessor, reader, writer & predicate).
 631
 632 =item B<process_accessors ($type, $value)>
 633
 634 This takes a C<$type> (accessor, reader, writer or predicate), and
 635 a C<$value> (the value passed into the constructor for each of the
 636 different types). It will then either generate the method itself
 637 (using the C<generate_*_method> methods listed below) or it will
 638 use the custom method passed through the constructor.
 639
 640 =over 4
 641
 642 =item B<generate_accessor_method>
 643
 644 =item B<generate_predicate_method>
 645
 646 =item B<generate_clearer_method>
 647
 648 =item B<generate_reader_method>
 649
 650 =item B<generate_writer_method>
 651
 652 =back
 653
 654 =over 4
 655
 656 =item B<generate_accessor_method_inline>
 657
 658 =item B<generate_predicate_method_inline>
 659
 660 =item B<generate_clearer_method_inline>
 661
 662 =item B<generate_reader_method_inline>
 663
 664 =item B<generate_writer_method_inline>
 665
 666 =back
 667
 668 =item B<remove_accessors>
 669
 670 This allows the attribute to remove the method for it's own
 671 I<accessor/reader/writer/predicate/clearer>. This is called by
 672 C<Class::MOP::Class::remove_attribute>.
 673
 674 =back
 675
 676 =head2 Introspection
 677
 678 =over 4
 679
 680 =item B<meta>
 681
 682 This will return a B<Class::MOP::Class> instance which is related
 683 to this class.
 684
 685 It should also be noted that B<Class::MOP> will actually bootstrap
 686 this module by installing a number of attribute meta-objects into
 687 it's metaclass. This will allow this class to reap all the benifits
 688 of the MOP when subclassing it.
 689
 690 =back
 691
 692 =head1 AUTHORS
 693
 694 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 695
 696 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 697
 698 =head1 COPYRIGHT AND LICENSE
 699
 700 Copyright 2006 by Infinity Interactive, Inc.
 701
 702 L<http://www.iinteractive.com>
 703
 704 This library is free software; you can redistribute it and/or modify
 705 it under the same terms as Perl itself.
 706
 707 =cut
 708
 709