lib/Class/MOP/Class.pm

   1
   2 package Class::MOP::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'reftype';
   9 use Sub::Name    'subname';
  10 use B            'svref_2object';
  11 use Clone         ();
  12
  13 our $VERSION = '0.03';
  14
  15 # Self-introspection
  16
  17 sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
  18
  19 # Creation
  20
  21 {
  22     # Metaclasses are singletons, so we cache them here.
  23     # there is no need to worry about destruction though
  24     # because they should die only when the program dies.
  25     # After all, do package definitions even get reaped?
  26     my %METAS;
  27
  28     sub initialize {
  29         my $class        = shift;
  30         my $package_name = shift;
  31         (defined $package_name && $package_name)
  32             || confess "You must pass a package name";
  33         # make sure the package name is not blessed
  34         $package_name = blessed($package_name) || $package_name;
  35         $class->construct_class_instance(':package' => $package_name, @_);
  36     }
  37
  38     # NOTE: (meta-circularity)
  39     # this is a special form of &construct_instance
  40     # (see below), which is used to construct class
  41     # meta-object instances for any Class::MOP::*
  42     # class. All other classes will use the more
  43     # normal &construct_instance.
  44     sub construct_class_instance {
  45         my $class        = shift;
  46         my %options      = @_;
  47         my $package_name = $options{':package'};
  48         (defined $package_name && $package_name)
  49             || confess "You must pass a package name";
  50         return $METAS{$package_name} if exists $METAS{$package_name};
  51         $class = blessed($class) || $class;
  52         # now create the metaclass
  53         my $meta;
  54         if ($class =~ /^Class::MOP::/) {
  55             $meta = bless {
  56                 '$:package'             => $package_name,
  57                 '%:attributes'          => {},
  58                 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
  59                 '$:method_metaclass'    => $options{':method_metaclass'}    || 'Class::MOP::Method',
  60             } => $class;
  61         }
  62         else {
  63             # NOTE:
  64             # it is safe to use meta here because
  65             # class will always be a subclass of
  66             # Class::MOP::Class, which defines meta
  67             $meta = bless $class->meta->construct_instance(%options) => $class
  68         }
  69         # and check the metaclass compatibility
  70         $meta->check_metaclass_compatability();
  71         $METAS{$package_name} = $meta;
  72     }
  73
  74     sub check_metaclass_compatability {
  75         my $self = shift;
  76
  77         # this is always okay ...
  78         return if blessed($self) eq 'Class::MOP::Class';
  79
  80         my @class_list = $self->class_precedence_list;
  81         shift @class_list; # shift off $self->name
  82
  83         foreach my $class_name (@class_list) {
  84             next unless $METAS{$class_name};
  85             my $meta = $METAS{$class_name};
  86             ($self->isa(blessed($meta)))
  87                 || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
  88                            " is not compatible with the " .
  89                            $class_name . "->meta => (" . (blessed($meta)) . ")";
  90         }
  91     }
  92 }
  93
  94 sub create {
  95     my ($class, $package_name, $package_version, %options) = @_;
  96     (defined $package_name && $package_name)
  97         || confess "You must pass a package name";
  98     my $code = "package $package_name;";
  99     $code .= "\$$package_name\:\:VERSION = '$package_version';"
 100         if defined $package_version;
 101     eval $code;
 102     confess "creation of $package_name failed : $@" if $@;
 103     my $meta = $class->initialize($package_name);
 104
 105     $meta->add_method('meta' => sub {
 106         Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
 107     });
 108
 109     $meta->superclasses(@{$options{superclasses}})
 110         if exists $options{superclasses};
 111     # NOTE:
 112     # process attributes first, so that they can
 113     # install accessors, but locally defined methods
 114     # can then overwrite them. It is maybe a little odd, but
 115     # I think this should be the order of things.
 116     if (exists $options{attributes}) {
 117         foreach my $attr (@{$options{attributes}}) {
 118             $meta->add_attribute($attr);
 119         }
 120     }
 121     if (exists $options{methods}) {
 122         foreach my $method_name (keys %{$options{methods}}) {
 123             $meta->add_method($method_name, $options{methods}->{$method_name});
 124         }
 125     }
 126     return $meta;
 127 }
 128
 129 ## Attribute readers
 130
 131 # NOTE:
 132 # all these attribute readers will be bootstrapped
 133 # away in the Class::MOP bootstrap section
 134
 135 sub name                { $_[0]->{'$:package'}             }
 136 sub get_attribute_map   { $_[0]->{'%:attributes'}          }
 137 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
 138 sub method_metaclass    { $_[0]->{'$:method_metaclass'}    }
 139
 140 # Instance Construction & Cloning
 141
 142 sub new_object {
 143     my $class = shift;
 144     # NOTE:
 145     # we need to protect the integrity of the
 146     # Class::MOP::Class singletons here, so we
 147     # delegate this to &construct_class_instance
 148     # which will deal with the singletons
 149     return $class->construct_class_instance(@_)
 150         if $class->name->isa('Class::MOP::Class');
 151     bless $class->construct_instance(@_) => $class->name;
 152 }
 153
 154 sub construct_instance {
 155     my ($class, %params) = @_;
 156     my $instance = {};
 157     foreach my $attr ($class->compute_all_applicable_attributes()) {
 158         my $init_arg = $attr->init_arg();
 159         # try to fetch the init arg from the %params ...
 160         my $val;
 161         $val = $params{$init_arg} if exists $params{$init_arg};
 162         # if nothing was in the %params, we can use the
 163         # attribute's default value (if it has one)
 164         $val ||= $attr->default($instance) if $attr->has_default();
 165         $instance->{$attr->name} = $val;
 166     }
 167     return $instance;
 168 }
 169
 170 sub clone_object {
 171     my $class    = shift;
 172     my $instance = shift;
 173     (blessed($instance) && $instance->isa($class->name))
 174         || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
 175     # NOTE:
 176     # we need to protect the integrity of the
 177     # Class::MOP::Class singletons here, they
 178     # should not be cloned.
 179     return $instance if $instance->isa('Class::MOP::Class');
 180     bless $class->clone_instance($instance, @_) => blessed($instance);
 181 }
 182
 183 sub clone_instance {
 184     my ($class, $instance, %params) = @_;
 185     (blessed($instance))
 186         || confess "You can only clone instances, \$self is not a blessed instance";
 187     # NOTE:
 188     # This will deep clone, which might
 189     # not be what you always want. So
 190     # the best thing is to write a more
 191     # controled &clone method locally
 192     # in the class (see Class::MOP)
 193     my $clone = Clone::clone($instance);
 194     foreach my $attr ($class->compute_all_applicable_attributes()) {
 195         my $init_arg = $attr->init_arg();
 196         # try to fetch the init arg from the %params ...
 197         $clone->{$attr->name} = $params{$init_arg}
 198             if exists $params{$init_arg};
 199     }
 200     return $clone;
 201 }
 202
 203 # Informational
 204
 205 # &name should be here too, but it is above
 206 # because it gets bootstrapped away
 207
 208 sub version {
 209     my $self = shift;
 210     no strict 'refs';
 211     ${$self->name . '::VERSION'};
 212 }
 213
 214 # Inheritance
 215
 216 sub superclasses {
 217     my $self = shift;
 218     no strict 'refs';
 219     if (@_) {
 220         my @supers = @_;
 221         @{$self->name . '::ISA'} = @supers;
 222     }
 223     @{$self->name . '::ISA'};
 224 }
 225
 226 sub class_precedence_list {
 227     my $self = shift;
 228     # NOTE:
 229     # We need to check for ciruclar inheirtance here.
 230     # This will do nothing if all is well, and blow
 231     # up otherwise. Yes, it's an ugly hack, better
 232     # suggestions are welcome.
 233     { $self->name->isa('This is a test for circular inheritance') }
 234     # ... and no back to our regularly scheduled program
 235     (
 236         $self->name,
 237         map {
 238             $self->initialize($_)->class_precedence_list()
 239         } $self->superclasses()
 240     );
 241 }
 242
 243 ## Methods
 244
 245 sub add_method {
 246     my ($self, $method_name, $method) = @_;
 247     (defined $method_name && $method_name)
 248         || confess "You must define a method name";
 249     # use reftype here to allow for blessed subs ...
 250     (reftype($method) && reftype($method) eq 'CODE')
 251         || confess "Your code block must be a CODE reference";
 252     my $full_method_name = ($self->name . '::' . $method_name);
 253
 254     no strict 'refs';
 255     no warnings 'redefine';
 256     *{$full_method_name} = subname $full_method_name => $method;
 257 }
 258
 259 sub alias_method {
 260     my ($self, $method_name, $method) = @_;
 261     (defined $method_name && $method_name)
 262         || confess "You must define a method name";
 263     # use reftype here to allow for blessed subs ...
 264     (reftype($method) && reftype($method) eq 'CODE')
 265         || confess "Your code block must be a CODE reference";
 266     my $full_method_name = ($self->name . '::' . $method_name);
 267
 268     no strict 'refs';
 269     no warnings 'redefine';
 270     *{$full_method_name} = $method;
 271 }
 272
 273 {
 274
 275     ## private utility functions for has_method
 276     my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
 277     my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } || '' };
 278
 279     sub has_method {
 280         my ($self, $method_name) = @_;
 281         (defined $method_name && $method_name)
 282             || confess "You must define a method name";
 283
 284         my $sub_name = ($self->name . '::' . $method_name);
 285
 286         no strict 'refs';
 287         return 0 if !defined(&{$sub_name});
 288         return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
 289                     $_find_subroutine_name->(\&{$sub_name})         ne '__ANON__';
 290         return 1;
 291     }
 292
 293 }
 294
 295 sub get_method {
 296     my ($self, $method_name) = @_;
 297     (defined $method_name && $method_name)
 298         || confess "You must define a method name";
 299
 300     no strict 'refs';
 301     return \&{$self->name . '::' . $method_name}
 302         if $self->has_method($method_name);
 303     return; # <- make sure to return undef
 304 }
 305
 306 sub remove_method {
 307     my ($self, $method_name) = @_;
 308     (defined $method_name && $method_name)
 309         || confess "You must define a method name";
 310
 311     my $removed_method = $self->get_method($method_name);
 312
 313     no strict 'refs';
 314     delete ${$self->name . '::'}{$method_name}
 315         if defined $removed_method;
 316
 317     return $removed_method;
 318 }
 319
 320 sub get_method_list {
 321     my $self = shift;
 322     no strict 'refs';
 323     grep { $self->has_method($_) } %{$self->name . '::'};
 324 }
 325
 326 sub compute_all_applicable_methods {
 327     my $self = shift;
 328     my @methods;
 329     # keep a record of what we have seen
 330     # here, this will handle all the
 331     # inheritence issues because we are
 332     # using the &class_precedence_list
 333     my (%seen_class, %seen_method);
 334     foreach my $class ($self->class_precedence_list()) {
 335         next if $seen_class{$class};
 336         $seen_class{$class}++;
 337         # fetch the meta-class ...
 338         my $meta = $self->initialize($class);
 339         foreach my $method_name ($meta->get_method_list()) {
 340             next if exists $seen_method{$method_name};
 341             $seen_method{$method_name}++;
 342             push @methods => {
 343                 name  => $method_name,
 344                 class => $class,
 345                 code  => $meta->get_method($method_name)
 346             };
 347         }
 348     }
 349     return @methods;
 350 }
 351
 352 sub find_all_methods_by_name {
 353     my ($self, $method_name) = @_;
 354     (defined $method_name && $method_name)
 355         || confess "You must define a method name to find";
 356     my @methods;
 357     # keep a record of what we have seen
 358     # here, this will handle all the
 359     # inheritence issues because we are
 360     # using the &class_precedence_list
 361     my %seen_class;
 362     foreach my $class ($self->class_precedence_list()) {
 363         next if $seen_class{$class};
 364         $seen_class{$class}++;
 365         # fetch the meta-class ...
 366         my $meta = $self->initialize($class);;
 367         push @methods => {
 368             name  => $method_name,
 369             class => $class,
 370             code  => $meta->get_method($method_name)
 371         } if $meta->has_method($method_name);
 372     }
 373     return @methods;
 374
 375 }
 376
 377 ## Attributes
 378
 379 sub add_attribute {
 380     my $self      = shift;
 381     # either we have an attribute object already
 382     # or we need to create one from the args provided
 383     my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
 384     # make sure it is derived from the correct type though
 385     ($attribute->isa('Class::MOP::Attribute'))
 386         || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
 387     $attribute->attach_to_class($self);
 388     $attribute->install_accessors();
 389     $self->get_attribute_map->{$attribute->name} = $attribute;
 390 }
 391
 392 sub has_attribute {
 393     my ($self, $attribute_name) = @_;
 394     (defined $attribute_name && $attribute_name)
 395         || confess "You must define an attribute name";
 396     exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
 397 }
 398
 399 sub get_attribute {
 400     my ($self, $attribute_name) = @_;
 401     (defined $attribute_name && $attribute_name)
 402         || confess "You must define an attribute name";
 403     return $self->get_attribute_map->{$attribute_name}
 404         if $self->has_attribute($attribute_name);
 405 }
 406
 407 sub remove_attribute {
 408     my ($self, $attribute_name) = @_;
 409     (defined $attribute_name && $attribute_name)
 410         || confess "You must define an attribute name";
 411     my $removed_attribute = $self->get_attribute_map->{$attribute_name};
 412     delete $self->get_attribute_map->{$attribute_name}
 413         if defined $removed_attribute;
 414     $removed_attribute->remove_accessors();
 415     $removed_attribute->detach_from_class();
 416     return $removed_attribute;
 417 }
 418
 419 sub get_attribute_list {
 420     my $self = shift;
 421     keys %{$self->get_attribute_map};
 422 }
 423
 424 sub compute_all_applicable_attributes {
 425     my $self = shift;
 426     my @attrs;
 427     # keep a record of what we have seen
 428     # here, this will handle all the
 429     # inheritence issues because we are
 430     # using the &class_precedence_list
 431     my (%seen_class, %seen_attr);
 432     foreach my $class ($self->class_precedence_list()) {
 433         next if $seen_class{$class};
 434         $seen_class{$class}++;
 435         # fetch the meta-class ...
 436         my $meta = $self->initialize($class);
 437         foreach my $attr_name ($meta->get_attribute_list()) {
 438             next if exists $seen_attr{$attr_name};
 439             $seen_attr{$attr_name}++;
 440             push @attrs => $meta->get_attribute($attr_name);
 441         }
 442     }
 443     return @attrs;
 444 }
 445
 446 # Class attributes
 447
 448 sub add_package_variable {
 449     my ($self, $variable, $initial_value) = @_;
 450     (defined $variable && $variable =~ /^[\$\@\%]/)
 451         || confess "variable name does not have a sigil";
 452
 453     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 454     if (defined $initial_value) {
 455         no strict 'refs';
 456         *{$self->name . '::' . $name} = $initial_value;
 457     }
 458     else {
 459         eval $sigil . $self->name . '::' . $name;
 460         confess "Could not create package variable ($variable) because : $@" if $@;
 461     }
 462 }
 463
 464 sub has_package_variable {
 465     my ($self, $variable) = @_;
 466     (defined $variable && $variable =~ /^[\$\@\%]/)
 467         || confess "variable name does not have a sigil";
 468     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 469     no strict 'refs';
 470     defined ${$self->name . '::'}{$name} ? 1 : 0;
 471 }
 472
 473 sub get_package_variable {
 474     my ($self, $variable) = @_;
 475     (defined $variable && $variable =~ /^[\$\@\%]/)
 476         || confess "variable name does not have a sigil";
 477     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 478     no strict 'refs';
 479     # try to fetch it first,.. see what happens
 480     eval '\\' . $sigil . $self->name . '::' . $name;
 481     confess "Could not get the package variable ($variable) because : $@" if $@;
 482     # if we didn't die, then we can return it
 483     # NOTE:
 484     # this is not ideal, better suggestions are welcome
 485     eval '\\' . $sigil . $self->name . '::' . $name;
 486 }
 487
 488 sub remove_package_variable {
 489     my ($self, $variable) = @_;
 490     (defined $variable && $variable =~ /^[\$\@\%]/)
 491         || confess "variable name does not have a sigil";
 492     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 493     no strict 'refs';
 494     delete ${$self->name . '::'}{$name};
 495 }
 496
 497 # class mixins
 498
 499 sub mixin {
 500     my ($self, $mixin) = @_;
 501     $mixin = $self->initialize($mixin)
 502         unless blessed($mixin);
 503
 504     my @attributes = map {
 505         $mixin->get_attribute($_)->clone()
 506     } $mixin->get_attribute_list;
 507
 508     my %methods = map  {
 509         my $method = $mixin->get_method($_);
 510         (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'))
 511             ? () : ($_ => $method)
 512     } $mixin->get_method_list;
 513
 514     foreach my $attr (@attributes) {
 515         $self->add_attribute($attr)
 516             unless $self->has_attribute($attr->name);
 517     }
 518
 519     foreach my $method_name (keys %methods) {
 520         $self->alias_method($method_name => $methods{$method_name})
 521             unless $self->has_method($method_name);
 522     }
 523 }
 524
 525 1;
 526
 527 __END__
 528
 529 =pod
 530
 531 =head1 NAME
 532
 533 Class::MOP::Class - Class Meta Object
 534
 535 =head1 SYNOPSIS
 536
 537   # use this for introspection ...
 538
 539   # add a method to Foo ...
 540   Foo->meta->add_method('bar' => sub { ... })
 541
 542   # get a list of all the classes searched
 543   # the method dispatcher in the correct order
 544   Foo->meta->class_precedence_list()
 545
 546   # remove a method from Foo
 547   Foo->meta->remove_method('bar');
 548
 549   # or use this to actually create classes ...
 550
 551   Class::MOP::Class->create('Bar' => '0.01' => (
 552       superclasses => [ 'Foo' ],
 553       attributes => [
 554           Class::MOP:::Attribute->new('$bar'),
 555           Class::MOP:::Attribute->new('$baz'),
 556       ],
 557       methods => {
 558           calculate_bar => sub { ... },
 559           construct_baz => sub { ... }
 560       }
 561   ));
 562
 563 =head1 DESCRIPTION
 564
 565 This is the largest and currently most complex part of the Perl 5
 566 meta-object protocol. It controls the introspection and
 567 manipulation of Perl 5 classes (and it can create them too). The
 568 best way to understand what this module can do, is to read the
 569 documentation for each of it's methods.
 570
 571 =head1 METHODS
 572
 573 =head2 Self Introspection
 574
 575 =over 4
 576
 577 =item B<meta>
 578
 579 This will return a B<Class::MOP::Class> instance which is related
 580 to this class. Thereby allowing B<Class::MOP::Class> to actually
 581 introspect itself.
 582
 583 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
 584 bootstrap this module by installing a number of attribute meta-objects
 585 into it's metaclass. This will allow this class to reap all the benifits
 586 of the MOP when subclassing it.
 587
 588 =back
 589
 590 =head2 Class construction
 591
 592 These methods will handle creating B<Class::MOP::Class> objects,
 593 which can be used to both create new classes, and analyze
 594 pre-existing classes.
 595
 596 This module will internally store references to all the instances
 597 you create with these methods, so that they do not need to be
 598 created any more than nessecary. Basically, they are singletons.
 599
 600 =over 4
 601
 602 =item B<create ($package_name, ?$package_version,
 603                 superclasses =E<gt> ?@superclasses,
 604                 methods      =E<gt> ?%methods,
 605                 attributes   =E<gt> ?%attributes)>
 606
 607 This returns a B<Class::MOP::Class> object, bringing the specified
 608 C<$package_name> into existence and adding any of the
 609 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
 610 to it.
 611
 612 =item B<initialize ($package_name)>
 613
 614 This initializes and returns returns a B<Class::MOP::Class> object
 615 for a given a C<$package_name>.
 616
 617 =item B<construct_class_instance (%options)>
 618
 619 This will construct an instance of B<Class::MOP::Class>, it is
 620 here so that we can actually "tie the knot" for B<Class::MOP::Class>
 621 to use C<construct_instance> once all the bootstrapping is done. This
 622 method is used internally by C<initialize> and should never be called
 623 from outside of that method really.
 624
 625 =item B<check_metaclass_compatability>
 626
 627 This method is called as the very last thing in the
 628 C<construct_class_instance> method. This will check that the
 629 metaclass you are creating is compatible with the metaclasses of all
 630 your ancestors. For more inforamtion about metaclass compatibility
 631 see the C<About Metaclass compatibility> section in L<Class::MOP>.
 632
 633 =back
 634
 635 =head2 Object instance construction and cloning
 636
 637 These methods are B<entirely optional>, it is up to you whether you want
 638 to use them or not.
 639
 640 =over 4
 641
 642 =item B<new_object (%params)>
 643
 644 This is a convience method for creating a new object of the class, and
 645 blessing it into the appropriate package as well. Ideally your class
 646 would call a C<new> this method like so:
 647
 648   sub MyClass::new {
 649       my ($class, %param) = @_;
 650       $class->meta->new_object(%params);
 651   }
 652
 653 Of course the ideal place for this would actually be in C<UNIVERSAL::>
 654 but that is considered bad style, so we do not do that.
 655
 656 =item B<construct_instance (%params)>
 657
 658 This method is used to construct an instace structure suitable for
 659 C<bless>-ing into your package of choice. It works in conjunction
 660 with the Attribute protocol to collect all applicable attributes.
 661
 662 This will construct and instance using a HASH ref as storage
 663 (currently only HASH references are supported). This will collect all
 664 the applicable attributes and layout out the fields in the HASH ref,
 665 it will then initialize them using either use the corresponding key
 666 in C<%params> or any default value or initializer found in the
 667 attribute meta-object.
 668
 669 =item B<clone_object ($instance, %params)>
 670
 671 This is a convience method for cloning an object instance, then
 672 blessing it into the appropriate package. Ideally your class
 673 would call a C<clone> this method like so:
 674
 675   sub MyClass::clone {
 676       my ($self, %param) = @_;
 677       $self->meta->clone_object($self, %params);
 678   }
 679
 680 Of course the ideal place for this would actually be in C<UNIVERSAL::>
 681 but that is considered bad style, so we do not do that.
 682
 683 =item B<clone_instance($instance, %params)>
 684
 685 This method is a compliment of C<construct_instance> (which means if
 686 you override C<construct_instance>, you need to override this one too).
 687
 688 This method will clone the C<$instance> structure created by the
 689 C<construct_instance> method, and apply any C<%params> passed to it
 690 to change the attribute values. The structure returned is (like with
 691 C<construct_instance>) an unC<bless>ed HASH reference, it is your
 692 responsibility to then bless this cloned structure into the right
 693 class.
 694
 695 =back
 696
 697 =head2 Informational
 698
 699 =over 4
 700
 701 =item B<name>
 702
 703 This is a read-only attribute which returns the package name for the
 704 given B<Class::MOP::Class> instance.
 705
 706 =item B<version>
 707
 708 This is a read-only attribute which returns the C<$VERSION> of the
 709 package for the given B<Class::MOP::Class> instance.
 710
 711 =back
 712
 713 =head2 Inheritance Relationships
 714
 715 =over 4
 716
 717 =item B<superclasses (?@superclasses)>
 718
 719 This is a read-write attribute which represents the superclass
 720 relationships of the class the B<Class::MOP::Class> instance is
 721 associated with. Basically, it can get and set the C<@ISA> for you.
 722
 723 B<NOTE:>
 724 Perl will occasionally perform some C<@ISA> and method caching, if
 725 you decide to change your superclass relationship at runtime (which
 726 is quite insane and very much not recommened), then you should be
 727 aware of this and the fact that this module does not make any
 728 attempt to address this issue.
 729
 730 =item B<class_precedence_list>
 731
 732 This computes the a list of all the class's ancestors in the same order
 733 in which method dispatch will be done. This is similair to
 734 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
 735
 736 =back
 737
 738 =head2 Methods
 739
 740 =over 4
 741
 742 =item B<method_metaclass>
 743
 744 =item B<add_method ($method_name, $method)>
 745
 746 This will take a C<$method_name> and CODE reference to that
 747 C<$method> and install it into the class's package.
 748
 749 B<NOTE>:
 750 This does absolutely nothing special to C<$method>
 751 other than use B<Sub::Name> to make sure it is tagged with the
 752 correct name, and therefore show up correctly in stack traces and
 753 such.
 754
 755 =item B<alias_method ($method_name, $method)>
 756
 757 This will take a C<$method_name> and CODE reference to that
 758 C<$method> and alias the method into the class's package.
 759
 760 B<NOTE>:
 761 Unlike C<add_method>, this will B<not> try to name the
 762 C<$method> using B<Sub::Name>, it only aliases the method in
 763 the class's package.
 764
 765 =item B<has_method ($method_name)>
 766
 767 This just provides a simple way to check if the class implements
 768 a specific C<$method_name>. It will I<not> however, attempt to check
 769 if the class inherits the method (use C<UNIVERSAL::can> for that).
 770
 771 This will correctly handle functions defined outside of the package
 772 that use a fully qualified name (C<sub Package::name { ... }>).
 773
 774 This will correctly handle functions renamed with B<Sub::Name> and
 775 installed using the symbol tables. However, if you are naming the
 776 subroutine outside of the package scope, you must use the fully
 777 qualified name, including the package name, for C<has_method> to
 778 correctly identify it.
 779
 780 This will attempt to correctly ignore functions imported from other
 781 packages using B<Exporter>. It breaks down if the function imported
 782 is an C<__ANON__> sub (such as with C<use constant>), which very well
 783 may be a valid method being applied to the class.
 784
 785 In short, this method cannot always be trusted to determine if the
 786 C<$method_name> is actually a method. However, it will DWIM about
 787 90% of the time, so it's a small trade off I think.
 788
 789 =item B<get_method ($method_name)>
 790
 791 This will return a CODE reference of the specified C<$method_name>,
 792 or return undef if that method does not exist.
 793
 794 =item B<remove_method ($method_name)>
 795
 796 This will attempt to remove a given C<$method_name> from the class.
 797 It will return the CODE reference that it has removed, and will
 798 attempt to use B<Sub::Name> to clear the methods associated name.
 799
 800 =item B<get_method_list>
 801
 802 This will return a list of method names for all I<locally> defined
 803 methods. It does B<not> provide a list of all applicable methods,
 804 including any inherited ones. If you want a list of all applicable
 805 methods, use the C<compute_all_applicable_methods> method.
 806
 807 =item B<compute_all_applicable_methods>
 808
 809 This will return a list of all the methods names this class will
 810 respond to, taking into account inheritance. The list will be a list of
 811 HASH references, each one containing the following information; method
 812 name, the name of the class in which the method lives and a CODE
 813 reference for the actual method.
 814
 815 =item B<find_all_methods_by_name ($method_name)>
 816
 817 This will traverse the inheritence hierarchy and locate all methods
 818 with a given C<$method_name>. Similar to
 819 C<compute_all_applicable_methods> it returns a list of HASH references
 820 with the following information; method name (which will always be the
 821 same as C<$method_name>), the name of the class in which the method
 822 lives and a CODE reference for the actual method.
 823
 824 The list of methods produced is a distinct list, meaning there are no
 825 duplicates in it. This is especially useful for things like object
 826 initialization and destruction where you only want the method called
 827 once, and in the correct order.
 828
 829 =back
 830
 831 =head2 Attributes
 832
 833 It should be noted that since there is no one consistent way to define
 834 the attributes of a class in Perl 5. These methods can only work with
 835 the information given, and can not easily discover information on
 836 their own. See L<Class::MOP::Attribute> for more details.
 837
 838 =over 4
 839
 840 =item B<attribute_metaclass>
 841
 842 =item B<get_attribute_map>
 843
 844 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
 845
 846 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
 847 instance associated with the given class, and associates it with
 848 the C<$attribute_name>. Unlike methods, attributes within the MOP
 849 are stored as meta-information only. They will be used later to
 850 construct instances from (see C<construct_instance> above).
 851 More details about the attribute meta-objects can be found in the
 852 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
 853 section.
 854
 855 It should be noted that any accessor, reader/writer or predicate
 856 methods which the C<$attribute_meta_object> has will be installed
 857 into the class at this time.
 858
 859 =item B<has_attribute ($attribute_name)>
 860
 861 Checks to see if this class has an attribute by the name of
 862 C<$attribute_name> and returns a boolean.
 863
 864 =item B<get_attribute ($attribute_name)>
 865
 866 Returns the attribute meta-object associated with C<$attribute_name>,
 867 if none is found, it will return undef.
 868
 869 =item B<remove_attribute ($attribute_name)>
 870
 871 This will remove the attribute meta-object stored at
 872 C<$attribute_name>, then return the removed attribute meta-object.
 873
 874 B<NOTE:>
 875 Removing an attribute will only affect future instances of
 876 the class, it will not make any attempt to remove the attribute from
 877 any existing instances of the class.
 878
 879 It should be noted that any accessor, reader/writer or predicate
 880 methods which the attribute meta-object stored at C<$attribute_name>
 881 has will be removed from the class at this time. This B<will> make
 882 these attributes somewhat inaccessable in previously created
 883 instances. But if you are crazy enough to do this at runtime, then
 884 you are crazy enough to deal with something like this :).
 885
 886 =item B<get_attribute_list>
 887
 888 This returns a list of attribute names which are defined in the local
 889 class. If you want a list of all applicable attributes for a class,
 890 use the C<compute_all_applicable_attributes> method.
 891
 892 =item B<compute_all_applicable_attributes>
 893
 894 This will traverse the inheritance heirachy and return a list of all
 895 the applicable attributes for this class. It does not construct a
 896 HASH reference like C<compute_all_applicable_methods> because all
 897 that same information is discoverable through the attribute
 898 meta-object itself.
 899
 900 =back
 901
 902 =head2 Package Variables
 903
 904 Since Perl's classes are built atop the Perl package system, it is
 905 fairly common to use package scoped variables for things like static
 906 class variables. The following methods are convience methods for
 907 the creation and inspection of package scoped variables.
 908
 909 =over 4
 910
 911 =item B<add_package_variable ($variable_name, ?$initial_value)>
 912
 913 Given a C<$variable_name>, which must contain a leading sigil, this
 914 method will create that variable within the package which houses the
 915 class. It also takes an optional C<$initial_value>, which must be a
 916 reference of the same type as the sigil of the C<$variable_name>
 917 implies.
 918
 919 =item B<get_package_variable ($variable_name)>
 920
 921 This will return a reference to the package variable in
 922 C<$variable_name>.
 923
 924 =item B<has_package_variable ($variable_name)>
 925
 926 Returns true (C<1>) if there is a package variable defined for
 927 C<$variable_name>, and false (C<0>) otherwise.
 928
 929 =item B<remove_package_variable ($variable_name)>
 930
 931 This will attempt to remove the package variable at C<$variable_name>.
 932
 933 =back
 934
 935 =head1 AUTHOR
 936
 937 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 938
 939 =head1 COPYRIGHT AND LICENSE
 940
 941 Copyright 2006 by Infinity Interactive, Inc.
 942
 943 L<http://www.iinteractive.com>
 944
 945 This library is free software; you can redistribute it and/or modify
 946 it under the same terms as Perl itself.
 947
 948 =cut