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