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