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