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