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($_[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     $meta->superclasses(@{$options{superclasses}})
 105         if exists $options{superclasses};
 106     # NOTE:
 107     # process attributes first, so that they can
 108     # install accessors, but locally defined methods
 109     # can then overwrite them. It is maybe a little odd, but
 110     # I think this should be the order of things.
 111     if (exists $options{attributes}) {
 112         foreach my $attr (@{$options{attributes}}) {
 113             $meta->add_attribute($attr);
 114         }
 115     }
 116     if (exists $options{methods}) {
 117         foreach my $method_name (keys %{$options{methods}}) {
 118             $meta->add_method($method_name, $options{methods}->{$method_name});
 119         }
 120     }
 121     return $meta;
 122 }
 123
 124 ## Attribute readers
 125
 126 # NOTE:
 127 # all these attribute readers will be bootstrapped
 128 # away in the Class::MOP bootstrap section
 129
 130 sub name                { $_[0]->{'$:package'}             }
 131 sub get_attribute_map   { $_[0]->{'%:attributes'}          }
 132 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
 133 sub method_metaclass    { $_[0]->{'$:method_metaclass'}    }
 134
 135 # Instance Construction & Cloning
 136
 137 sub new_object {
 138     my $class = shift;
 139     # NOTE:
 140     # we need to protect the integrity of the
 141     # Class::MOP::Class singletons here, so we
 142     # delegate this to &construct_class_instance
 143     # which will deal with the singletons
 144     return $class->construct_class_instance(@_)
 145         if $class->name->isa('Class::MOP::Class');
 146     bless $class->construct_instance(@_) => $class->name;
 147 }
 148
 149 sub construct_instance {
 150     my ($class, %params) = @_;
 151     my $instance = {};
 152     foreach my $attr ($class->compute_all_applicable_attributes()) {
 153         my $init_arg = $attr->init_arg();
 154         # try to fetch the init arg from the %params ...
 155         my $val;
 156         $val = $params{$init_arg} if exists $params{$init_arg};
 157         # if nothing was in the %params, we can use the
 158         # attribute's default value (if it has one)
 159         $val ||= $attr->default($instance) if $attr->has_default();
 160         $instance->{$attr->name} = $val;
 161     }
 162     return $instance;
 163 }
 164
 165 sub clone_object {
 166     my $class    = shift;
 167     my $instance = shift;
 168     (blessed($instance) && $instance->isa($class->name))
 169         || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
 170     # NOTE:
 171     # we need to protect the integrity of the
 172     # Class::MOP::Class singletons here, they
 173     # should not be cloned.
 174     return $instance if $instance->isa('Class::MOP::Class');
 175     bless $class->clone_instance($instance, @_) => blessed($instance);
 176 }
 177
 178 sub clone_instance {
 179     my ($class, $instance, %params) = @_;
 180     (blessed($instance))
 181         || confess "You can only clone instances, \$self is not a blessed instance";
 182     # NOTE:
 183     # This will deep clone, which might
 184     # not be what you always want. So
 185     # the best thing is to write a more
 186     # controled &clone method locally
 187     # in the class (see Class::MOP)
 188     my $clone = Clone::clone($instance);
 189     foreach my $attr ($class->compute_all_applicable_attributes()) {
 190         my $init_arg = $attr->init_arg();
 191         # try to fetch the init arg from the %params ...
 192         $clone->{$attr->name} = $params{$init_arg}
 193             if exists $params{$init_arg};
 194     }
 195     return $clone;
 196 }
 197
 198 # Informational
 199
 200 # &name should be here too, but it is above
 201 # because it gets bootstrapped away
 202
 203 sub version {
 204     my $self = shift;
 205     no strict 'refs';
 206     ${$self->name . '::VERSION'};
 207 }
 208
 209 # Inheritance
 210
 211 sub superclasses {
 212     my $self = shift;
 213     no strict 'refs';
 214     if (@_) {
 215         my @supers = @_;
 216         @{$self->name . '::ISA'} = @supers;
 217     }
 218     @{$self->name . '::ISA'};
 219 }
 220
 221 sub class_precedence_list {
 222     my $self = shift;
 223     # NOTE:
 224     # We need to check for ciruclar inheirtance here.
 225     # This will do nothing if all is well, and blow
 226     # up otherwise. Yes, it's an ugly hack, better
 227     # suggestions are welcome.
 228     { $self->name->isa('This is a test for circular inheritance') }
 229     # ... and no back to our regularly scheduled program
 230     (
 231         $self->name,
 232         map {
 233             $self->initialize($_)->class_precedence_list()
 234         } $self->superclasses()
 235     );
 236 }
 237
 238 ## Methods
 239
 240 sub add_method {
 241     my ($self, $method_name, $method) = @_;
 242     (defined $method_name && $method_name)
 243         || confess "You must define a method name";
 244     # use reftype here to allow for blessed subs ...
 245     (reftype($method) && reftype($method) eq 'CODE')
 246         || confess "Your code block must be a CODE reference";
 247     my $full_method_name = ($self->name . '::' . $method_name);
 248
 249     no strict 'refs';
 250     no warnings 'redefine';
 251     *{$full_method_name} = subname $full_method_name => $method;
 252 }
 253
 254 {
 255
 256     ## private utility functions for has_method
 257     my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
 258     my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } || '' };
 259
 260     sub has_method {
 261         my ($self, $method_name) = @_;
 262         (defined $method_name && $method_name)
 263             || confess "You must define a method name";
 264
 265         my $sub_name = ($self->name . '::' . $method_name);
 266
 267         no strict 'refs';
 268         return 0 if !defined(&{$sub_name});
 269         return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
 270                     $_find_subroutine_name->(\&{$sub_name})         ne '__ANON__';
 271         return 1;
 272     }
 273
 274 }
 275
 276 sub get_method {
 277     my ($self, $method_name) = @_;
 278     (defined $method_name && $method_name)
 279         || confess "You must define a method name";
 280
 281     no strict 'refs';
 282     return \&{$self->name . '::' . $method_name}
 283         if $self->has_method($method_name);
 284     return; # <- make sure to return undef
 285 }
 286
 287 sub remove_method {
 288     my ($self, $method_name) = @_;
 289     (defined $method_name && $method_name)
 290         || confess "You must define a method name";
 291
 292     my $removed_method = $self->get_method($method_name);
 293
 294     no strict 'refs';
 295     delete ${$self->name . '::'}{$method_name}
 296         if defined $removed_method;
 297
 298     return $removed_method;
 299 }
 300
 301 sub get_method_list {
 302     my $self = shift;
 303     no strict 'refs';
 304     grep { $self->has_method($_) } %{$self->name . '::'};
 305 }
 306
 307 sub compute_all_applicable_methods {
 308     my $self = shift;
 309     my @methods;
 310     # keep a record of what we have seen
 311     # here, this will handle all the
 312     # inheritence issues because we are
 313     # using the &class_precedence_list
 314     my (%seen_class, %seen_method);
 315     foreach my $class ($self->class_precedence_list()) {
 316         next if $seen_class{$class};
 317         $seen_class{$class}++;
 318         # fetch the meta-class ...
 319         my $meta = $self->initialize($class);
 320         foreach my $method_name ($meta->get_method_list()) {
 321             next if exists $seen_method{$method_name};
 322             $seen_method{$method_name}++;
 323             push @methods => {
 324                 name  => $method_name,
 325                 class => $class,
 326                 code  => $meta->get_method($method_name)
 327             };
 328         }
 329     }
 330     return @methods;
 331 }
 332
 333 sub find_all_methods_by_name {
 334     my ($self, $method_name) = @_;
 335     (defined $method_name && $method_name)
 336         || confess "You must define a method name to find";
 337     my @methods;
 338     # keep a record of what we have seen
 339     # here, this will handle all the
 340     # inheritence issues because we are
 341     # using the &class_precedence_list
 342     my %seen_class;
 343     foreach my $class ($self->class_precedence_list()) {
 344         next if $seen_class{$class};
 345         $seen_class{$class}++;
 346         # fetch the meta-class ...
 347         my $meta = $self->initialize($class);
 348         push @methods => {
 349             name  => $method_name,
 350             class => $class,
 351             code  => $meta->get_method($method_name)
 352         } if $meta->has_method($method_name);
 353     }
 354     return @methods;
 355
 356 }
 357
 358 ## Attributes
 359
 360 sub add_attribute {
 361     my $self      = shift;
 362     # either we have an attribute object already
 363     # or we need to create one from the args provided
 364     my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
 365     # make sure it is derived from the correct type though
 366     ($attribute->isa('Class::MOP::Attribute'))
 367         || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
 368     $attribute->attach_to_class($self);
 369     $attribute->install_accessors();
 370     $self->get_attribute_map->{$attribute->name} = $attribute;
 371 }
 372
 373 sub has_attribute {
 374     my ($self, $attribute_name) = @_;
 375     (defined $attribute_name && $attribute_name)
 376         || confess "You must define an attribute name";
 377     exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
 378 }
 379
 380 sub get_attribute {
 381     my ($self, $attribute_name) = @_;
 382     (defined $attribute_name && $attribute_name)
 383         || confess "You must define an attribute name";
 384     return $self->get_attribute_map->{$attribute_name}
 385         if $self->has_attribute($attribute_name);
 386 }
 387
 388 sub remove_attribute {
 389     my ($self, $attribute_name) = @_;
 390     (defined $attribute_name && $attribute_name)
 391         || confess "You must define an attribute name";
 392     my $removed_attribute = $self->get_attribute_map->{$attribute_name};
 393     delete $self->get_attribute_map->{$attribute_name}
 394         if defined $removed_attribute;
 395     $removed_attribute->remove_accessors();
 396     $removed_attribute->detach_from_class();
 397     return $removed_attribute;
 398 }
 399
 400 sub get_attribute_list {
 401     my $self = shift;
 402     keys %{$self->get_attribute_map};
 403 }
 404
 405 sub compute_all_applicable_attributes {
 406     my $self = shift;
 407     my @attrs;
 408     # keep a record of what we have seen
 409     # here, this will handle all the
 410     # inheritence issues because we are
 411     # using the &class_precedence_list
 412     my (%seen_class, %seen_attr);
 413     foreach my $class ($self->class_precedence_list()) {
 414         next if $seen_class{$class};
 415         $seen_class{$class}++;
 416         # fetch the meta-class ...
 417         my $meta = $self->initialize($class);
 418         foreach my $attr_name ($meta->get_attribute_list()) {
 419             next if exists $seen_attr{$attr_name};
 420             $seen_attr{$attr_name}++;
 421             push @attrs => $meta->get_attribute($attr_name);
 422         }
 423     }
 424     return @attrs;
 425 }
 426
 427 # Class attributes
 428
 429 sub add_package_variable {
 430     my ($self, $variable, $initial_value) = @_;
 431     (defined $variable && $variable =~ /^[\$\@\%]/)
 432         || confess "variable name does not have a sigil";
 433
 434     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 435     if (defined $initial_value) {
 436         no strict 'refs';
 437         *{$self->name . '::' . $name} = $initial_value;
 438     }
 439     else {
 440         eval $sigil . $self->name . '::' . $name;
 441         confess "Could not create package variable ($variable) because : $@" if $@;
 442     }
 443 }
 444
 445 sub has_package_variable {
 446     my ($self, $variable) = @_;
 447     (defined $variable && $variable =~ /^[\$\@\%]/)
 448         || confess "variable name does not have a sigil";
 449     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 450     no strict 'refs';
 451     defined ${$self->name . '::'}{$name} ? 1 : 0;
 452 }
 453
 454 sub get_package_variable {
 455     my ($self, $variable) = @_;
 456     (defined $variable && $variable =~ /^[\$\@\%]/)
 457         || confess "variable name does not have a sigil";
 458     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 459     no strict 'refs';
 460     # try to fetch it first,.. see what happens
 461     eval '\\' . $sigil . $self->name . '::' . $name;
 462     confess "Could not get the package variable ($variable) because : $@" if $@;
 463     # if we didn't die, then we can return it
 464     # NOTE:
 465     # this is not ideal, better suggestions are welcome
 466     eval '\\' . $sigil . $self->name . '::' . $name;
 467 }
 468
 469 sub remove_package_variable {
 470     my ($self, $variable) = @_;
 471     (defined $variable && $variable =~ /^[\$\@\%]/)
 472         || confess "variable name does not have a sigil";
 473     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 474     no strict 'refs';
 475     delete ${$self->name . '::'}{$name};
 476 }
 477
 478 1;
 479
 480 __END__
 481
 482 =pod
 483
 484 =head1 NAME
 485
 486 Class::MOP::Class - Class Meta Object
 487
 488 =head1 SYNOPSIS
 489
 490   # use this for introspection ...
 491
 492   package Foo;
 493   sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
 494
 495   # elsewhere in the code ...
 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. Ideally your class
 631 would call a C<clone> this method like so:
 632
 633   sub MyClass::clone {
 634       my ($self, %param) = @_;
 635       $self->meta->clone_object($self, %params);
 636   }
 637
 638 Of course the ideal place for this would actually be in C<UNIVERSAL::>
 639 but that is considered bad style, so we do not do that.
 640
 641 =item B<clone_instance($instance, %params)>
 642
 643 This method is a compliment of C<construct_instance> (which means if
 644 you override C<construct_instance>, you need to override this one too).
 645
 646 This method will clone the C<$instance> structure created by the
 647 C<construct_instance> method, and apply any C<%params> passed to it
 648 to change the attribute values. The structure returned is (like with
 649 C<construct_instance>) an unC<bless>ed HASH reference, it is your
 650 responsibility to then bless this cloned structure into the right
 651 class.
 652
 653 =back
 654
 655 =head2 Informational
 656
 657 =over 4
 658
 659 =item B<name>
 660
 661 This is a read-only attribute which returns the package name for the
 662 given B<Class::MOP::Class> instance.
 663
 664 =item B<version>
 665
 666 This is a read-only attribute which returns the C<$VERSION> of the
 667 package for the given B<Class::MOP::Class> instance.
 668
 669 =back
 670
 671 =head2 Inheritance Relationships
 672
 673 =over 4
 674
 675 =item B<superclasses (?@superclasses)>
 676
 677 This is a read-write attribute which represents the superclass
 678 relationships of the class the B<Class::MOP::Class> instance is
 679 associated with. Basically, it can get and set the C<@ISA> for you.
 680
 681 B<NOTE:>
 682 Perl will occasionally perform some C<@ISA> and method caching, if
 683 you decide to change your superclass relationship at runtime (which
 684 is quite insane and very much not recommened), then you should be
 685 aware of this and the fact that this module does not make any
 686 attempt to address this issue.
 687
 688 =item B<class_precedence_list>
 689
 690 This computes the a list of all the class's ancestors in the same order
 691 in which method dispatch will be done. This is similair to
 692 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
 693
 694 =back
 695
 696 =head2 Methods
 697
 698 =over 4
 699
 700 =item B<method_metaclass>
 701
 702 =item B<add_method ($method_name, $method)>
 703
 704 This will take a C<$method_name> and CODE reference to that
 705 C<$method> and install it into the class's package.
 706
 707 B<NOTE>:
 708 This does absolutely nothing special to C<$method>
 709 other than use B<Sub::Name> to make sure it is tagged with the
 710 correct name, and therefore show up correctly in stack traces and
 711 such.
 712
 713 =item B<has_method ($method_name)>
 714
 715 This just provides a simple way to check if the class implements
 716 a specific C<$method_name>. It will I<not> however, attempt to check
 717 if the class inherits the method (use C<UNIVERSAL::can> for that).
 718
 719 This will correctly handle functions defined outside of the package
 720 that use a fully qualified name (C<sub Package::name { ... }>).
 721
 722 This will correctly handle functions renamed with B<Sub::Name> and
 723 installed using the symbol tables. However, if you are naming the
 724 subroutine outside of the package scope, you must use the fully
 725 qualified name, including the package name, for C<has_method> to
 726 correctly identify it.
 727
 728 This will attempt to correctly ignore functions imported from other
 729 packages using B<Exporter>. It breaks down if the function imported
 730 is an C<__ANON__> sub (such as with C<use constant>), which very well
 731 may be a valid method being applied to the class.
 732
 733 In short, this method cannot always be trusted to determine if the
 734 C<$method_name> is actually a method. However, it will DWIM about
 735 90% of the time, so it's a small trade off I think.
 736
 737 =item B<get_method ($method_name)>
 738
 739 This will return a CODE reference of the specified C<$method_name>,
 740 or return undef if that method does not exist.
 741
 742 =item B<remove_method ($method_name)>
 743
 744 This will attempt to remove a given C<$method_name> from the class.
 745 It will return the CODE reference that it has removed, and will
 746 attempt to use B<Sub::Name> to clear the methods associated name.
 747
 748 =item B<get_method_list>
 749
 750 This will return a list of method names for all I<locally> defined
 751 methods. It does B<not> provide a list of all applicable methods,
 752 including any inherited ones. If you want a list of all applicable
 753 methods, use the C<compute_all_applicable_methods> method.
 754
 755 =item B<compute_all_applicable_methods>
 756
 757 This will return a list of all the methods names this class will
 758 respond to, taking into account inheritance. The list will be a list of
 759 HASH references, each one containing the following information; method
 760 name, the name of the class in which the method lives and a CODE
 761 reference for the actual method.
 762
 763 =item B<find_all_methods_by_name ($method_name)>
 764
 765 This will traverse the inheritence hierarchy and locate all methods
 766 with a given C<$method_name>. Similar to
 767 C<compute_all_applicable_methods> it returns a list of HASH references
 768 with the following information; method name (which will always be the
 769 same as C<$method_name>), the name of the class in which the method
 770 lives and a CODE reference for the actual method.
 771
 772 The list of methods produced is a distinct list, meaning there are no
 773 duplicates in it. This is especially useful for things like object
 774 initialization and destruction where you only want the method called
 775 once, and in the correct order.
 776
 777 =back
 778
 779 =head2 Attributes
 780
 781 It should be noted that since there is no one consistent way to define
 782 the attributes of a class in Perl 5. These methods can only work with
 783 the information given, and can not easily discover information on
 784 their own. See L<Class::MOP::Attribute> for more details.
 785
 786 =over 4
 787
 788 =item B<attribute_metaclass>
 789
 790 =item B<get_attribute_map>
 791
 792 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
 793
 794 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
 795 instance associated with the given class, and associates it with
 796 the C<$attribute_name>. Unlike methods, attributes within the MOP
 797 are stored as meta-information only. They will be used later to
 798 construct instances from (see C<construct_instance> above).
 799 More details about the attribute meta-objects can be found in the
 800 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
 801 section.
 802
 803 It should be noted that any accessor, reader/writer or predicate
 804 methods which the C<$attribute_meta_object> has will be installed
 805 into the class at this time.
 806
 807 =item B<has_attribute ($attribute_name)>
 808
 809 Checks to see if this class has an attribute by the name of
 810 C<$attribute_name> and returns a boolean.
 811
 812 =item B<get_attribute ($attribute_name)>
 813
 814 Returns the attribute meta-object associated with C<$attribute_name>,
 815 if none is found, it will return undef.
 816
 817 =item B<remove_attribute ($attribute_name)>
 818
 819 This will remove the attribute meta-object stored at
 820 C<$attribute_name>, then return the removed attribute meta-object.
 821
 822 B<NOTE:>
 823 Removing an attribute will only affect future instances of
 824 the class, it will not make any attempt to remove the attribute from
 825 any existing instances of the class.
 826
 827 It should be noted that any accessor, reader/writer or predicate
 828 methods which the attribute meta-object stored at C<$attribute_name>
 829 has will be removed from the class at this time. This B<will> make
 830 these attributes somewhat inaccessable in previously created
 831 instances. But if you are crazy enough to do this at runtime, then
 832 you are crazy enough to deal with something like this :).
 833
 834 =item B<get_attribute_list>
 835
 836 This returns a list of attribute names which are defined in the local
 837 class. If you want a list of all applicable attributes for a class,
 838 use the C<compute_all_applicable_attributes> method.
 839
 840 =item B<compute_all_applicable_attributes>
 841
 842 This will traverse the inheritance heirachy and return a list of all
 843 the applicable attributes for this class. It does not construct a
 844 HASH reference like C<compute_all_applicable_methods> because all
 845 that same information is discoverable through the attribute
 846 meta-object itself.
 847
 848 =back
 849
 850 =head2 Package Variables
 851
 852 Since Perl's classes are built atop the Perl package system, it is
 853 fairly common to use package scoped variables for things like static
 854 class variables. The following methods are convience methods for
 855 the creation and inspection of package scoped variables.
 856
 857 =over 4
 858
 859 =item B<add_package_variable ($variable_name, ?$initial_value)>
 860
 861 Given a C<$variable_name>, which must contain a leading sigil, this
 862 method will create that variable within the package which houses the
 863 class. It also takes an optional C<$initial_value>, which must be a
 864 reference of the same type as the sigil of the C<$variable_name>
 865 implies.
 866
 867 =item B<get_package_variable ($variable_name)>
 868
 869 This will return a reference to the package variable in
 870 C<$variable_name>.
 871
 872 =item B<has_package_variable ($variable_name)>
 873
 874 Returns true (C<1>) if there is a package variable defined for
 875 C<$variable_name>, and false (C<0>) otherwise.
 876
 877 =item B<remove_package_variable ($variable_name)>
 878
 879 This will attempt to remove the package variable at C<$variable_name>.
 880
 881 =back
 882
 883 =head1 AUTHOR
 884
 885 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 886
 887 =head1 COPYRIGHT AND LICENSE
 888
 889 Copyright 2006 by Infinity Interactive, Inc.
 890
 891 L<http://www.iinteractive.com>
 892
 893 This library is free software; you can redistribute it and/or modify
 894 it under the same terms as Perl itself.
 895
 896 =cut