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