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