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