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