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