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