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