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