lib/Class/MOP/Attribute.pm

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