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