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