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