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