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