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