Moose-2.1405HEADMoose-2.1405master

1 files changed, 2312 insertions, 0 deletions

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
new file mode 100644
index 0000000..c5e1bae
--- /dev/null
+++ b/lib/Class/MOP/Class.pm
@@ -0,0 +1,2312 @@
+package Class::MOP::Class;
+our $VERSION = '2.1405';
+
+use strict;
+use warnings;
+
+use Class::MOP::Instance;
+use Class::MOP::Method::Wrapped;
+use Class::MOP::Method::Accessor;
+use Class::MOP::Method::Constructor;
+use Class::MOP::MiniTrait;
+
+use Carp         'confess';
+use Module::Runtime 'use_package_optimistically';
+use Scalar::Util 'blessed';
+use Sub::Name    'subname';
+use Try::Tiny;
+use List::Util 1.33 'all';
+
+use parent 'Class::MOP::Module',
+         'Class::MOP::Mixin::HasAttributes',
+         'Class::MOP::Mixin::HasMethods',
+         'Class::MOP::Mixin::HasOverloads';
+
+# Creation
+
+sub initialize {
+    my $class = shift;
+
+    my $package_name;
+
+    if ( @_ % 2 ) {
+        $package_name = shift;
+    } else {
+        my %options = @_;
+        $package_name = $options{package};
+    }
+
+    ($package_name && !ref($package_name))
+        || ($class||__PACKAGE__)->_throw_exception( InitializeTakesUnBlessedPackageName => package_name => $package_name );
+    return Class::MOP::get_metaclass_by_name($package_name)
+        || $class->_construct_class_instance(package => $package_name, @_);
+}
+
+sub reinitialize {
+    my ( $class, @args ) = @_;
+    unshift @args, "package" if @args % 2;
+    my %options = @args;
+    my $old_metaclass = blessed($options{package})
+        ? $options{package}
+        : Class::MOP::get_metaclass_by_name($options{package});
+    $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name)
+        if !exists $options{weaken}
+        && blessed($old_metaclass)
+        && $old_metaclass->isa('Class::MOP::Class');
+    $old_metaclass->_remove_generated_metaobjects
+        if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
+    my $new_metaclass = $class->SUPER::reinitialize(%options);
+    $new_metaclass->_restore_metaobjects_from($old_metaclass)
+        if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
+    return $new_metaclass;
+}
+
+# NOTE: (meta-circularity)
+# this is a special form of _construct_instance
+# (see below), which is used to construct class
+# meta-object instances for any Class::MOP::*
+# class. All other classes will use the more
+# normal &construct_instance.
+sub _construct_class_instance {
+    my $class        = shift;
+    my $options      = @_ == 1 ? $_[0] : {@_};
+    my $package_name = $options->{package};
+    (defined $package_name && $package_name)
+        || $class->_throw_exception("ConstructClassInstanceTakesPackageName");
+    # NOTE:
+    # return the metaclass if we have it cached,
+    # and it is still defined (it has not been
+    # reaped by DESTROY yet, which can happen
+    # annoyingly enough during global destruction)
+
+    if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
+        return $meta;
+    }
+
+    $class
+        = ref $class
+        ? $class->_real_ref_name
+        : $class;
+
+    # now create the metaclass
+    my $meta;
+    if ($class eq 'Class::MOP::Class') {
+        $meta = $class->_new($options);
+    }
+    else {
+        # NOTE:
+        # it is safe to use meta here because
+        # class will always be a subclass of
+        # Class::MOP::Class, which defines meta
+        $meta = $class->meta->_construct_instance($options)
+    }
+
+    # and check the metaclass compatibility
+    $meta->_check_metaclass_compatibility();
+
+    Class::MOP::store_metaclass_by_name($package_name, $meta);
+
+    # NOTE:
+    # we need to weaken any anon classes
+    # so that they can call DESTROY properly
+    Class::MOP::weaken_metaclass($package_name) if $options->{weaken};
+
+    $meta;
+}
+
+sub _real_ref_name {
+    my $self = shift;
+
+    # NOTE: we need to deal with the possibility of class immutability here,
+    # and then get the name of the class appropriately
+    return $self->is_immutable
+        ? $self->_get_mutable_metaclass_name()
+        : ref $self;
+}
+
+sub _new {
+    my $class = shift;
+
+    return Class::MOP::Class->initialize($class)->new_object(@_)
+        if $class ne __PACKAGE__;
+
+    my $options = @_ == 1 ? $_[0] : {@_};
+
+    return bless {
+        # inherited from Class::MOP::Package
+        'package' => $options->{package},
+
+        # NOTE:
+        # since the following attributes will
+        # actually be loaded from the symbol
+        # table, and actually bypass the instance
+        # entirely, we can just leave these things
+        # listed here for reference, because they
+        # should not actually have a value associated
+        # with the slot.
+        'namespace' => \undef,
+        'methods'   => {},
+
+        # inherited from Class::MOP::Module
+        'version'   => \undef,
+        'authority' => \undef,
+
+        # defined in Class::MOP::Class
+        'superclasses' => \undef,
+
+        'attributes' => {},
+        'attribute_metaclass' =>
+            ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
+        'method_metaclass' =>
+            ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
+        'wrapped_method_metaclass' => (
+            $options->{'wrapped_method_metaclass'}
+                || 'Class::MOP::Method::Wrapped'
+        ),
+        'instance_metaclass' =>
+            ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
+        'immutable_trait' => (
+            $options->{'immutable_trait'}
+                || 'Class::MOP::Class::Immutable::Trait'
+        ),
+        'constructor_name' => ( $options->{constructor_name} || 'new' ),
+        'constructor_class' => (
+            $options->{constructor_class} || 'Class::MOP::Method::Constructor'
+        ),
+        'destructor_class' => $options->{destructor_class},
+    }, $class;
+}
+
+## Metaclass compatibility
+{
+    my %base_metaclass = (
+        attribute_metaclass      => 'Class::MOP::Attribute',
+        method_metaclass         => 'Class::MOP::Method',
+        wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
+        instance_metaclass       => 'Class::MOP::Instance',
+        constructor_class        => 'Class::MOP::Method::Constructor',
+        destructor_class         => 'Class::MOP::Method::Destructor',
+    );
+
+    sub _base_metaclasses { %base_metaclass }
+}
+
+sub _check_metaclass_compatibility {
+    my $self = shift;
+
+    my @superclasses = $self->superclasses
+        or return;
+
+    $self->_fix_metaclass_incompatibility(@superclasses);
+
+    my %base_metaclass = $self->_base_metaclasses;
+
+    # this is always okay ...
+    return
+        if ref($self) eq 'Class::MOP::Class'
+            && all {
+                my $meta = $self->$_;
+                !defined($meta) || $meta eq $base_metaclass{$_};
+        }
+        keys %base_metaclass;
+
+    for my $superclass (@superclasses) {
+        $self->_check_class_metaclass_compatibility($superclass);
+    }
+
+    for my $metaclass_type ( keys %base_metaclass ) {
+        next unless defined $self->$metaclass_type;
+        for my $superclass (@superclasses) {
+            $self->_check_single_metaclass_compatibility( $metaclass_type,
+                $superclass );
+        }
+    }
+}
+
+sub _check_class_metaclass_compatibility {
+    my $self = shift;
+    my ( $superclass_name ) = @_;
+
+    if (!$self->_class_metaclass_is_compatible($superclass_name)) {
+        my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
+
+        my $super_meta_type = $super_meta->_real_ref_name;
+
+        $self->_throw_exception( IncompatibleMetaclassOfSuperclass => class_name           => $self->name,
+                                                              class_meta_type      => ref( $self ),
+                                                              superclass_name      => $superclass_name,
+                                                              superclass_meta_type => $super_meta_type
+                       );
+    }
+}
+
+sub _class_metaclass_is_compatible {
+    my $self = shift;
+    my ( $superclass_name ) = @_;
+
+    my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+        || return 1;
+
+    my $super_meta_name = $super_meta->_real_ref_name;
+
+    return $self->_is_compatible_with($super_meta_name);
+}
+
+sub _check_single_metaclass_compatibility {
+    my $self = shift;
+    my ( $metaclass_type, $superclass_name ) = @_;
+
+    if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
+        my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
+
+        $self->_throw_exception( MetaclassTypeIncompatible => class_name      => $self->name,
+                                                      superclass_name => $superclass_name,
+                                                      metaclass_type  => $metaclass_type
+                       );
+    }
+}
+
+sub _single_metaclass_is_compatible {
+    my $self = shift;
+    my ( $metaclass_type, $superclass_name ) = @_;
+
+    my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+        || return 1;
+
+    # for instance, Moose::Meta::Class has a error_class attribute, but
+    # Class::MOP::Class doesn't - this shouldn't be an error
+    return 1 unless $super_meta->can($metaclass_type);
+    # for instance, Moose::Meta::Class has a destructor_class, but
+    # Class::MOP::Class doesn't - this shouldn't be an error
+    return 1 unless defined $super_meta->$metaclass_type;
+    # if metaclass is defined in superclass but not here, it's not compatible
+    # this is a really odd case
+    return 0 unless defined $self->$metaclass_type;
+
+    return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
+}
+
+sub _fix_metaclass_incompatibility {
+    my $self = shift;
+    my @supers = map { Class::MOP::Class->initialize($_) } @_;
+
+    my $necessary = 0;
+    for my $super (@supers) {
+        $necessary = 1
+            if $self->_can_fix_metaclass_incompatibility($super);
+    }
+    return unless $necessary;
+
+    for my $super (@supers) {
+        if (!$self->_class_metaclass_is_compatible($super->name)) {
+            $self->_fix_class_metaclass_incompatibility($super);
+        }
+    }
+
+    my %base_metaclass = $self->_base_metaclasses;
+    for my $metaclass_type (keys %base_metaclass) {
+        for my $super (@supers) {
+            if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
+                $self->_fix_single_metaclass_incompatibility(
+                    $metaclass_type, $super
+                );
+            }
+        }
+    }
+}
+
+sub _can_fix_metaclass_incompatibility {
+    my $self = shift;
+    my ($super_meta) = @_;
+
+    return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
+
+    my %base_metaclass = $self->_base_metaclasses;
+    for my $metaclass_type (keys %base_metaclass) {
+        return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
+    }
+
+    return;
+}
+
+sub _class_metaclass_can_be_made_compatible {
+    my $self = shift;
+    my ($super_meta) = @_;
+
+    return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
+}
+
+sub _single_metaclass_can_be_made_compatible {
+    my $self = shift;
+    my ($super_meta, $metaclass_type) = @_;
+
+    my $specific_meta = $self->$metaclass_type;
+
+    return unless $super_meta->can($metaclass_type);
+    my $super_specific_meta = $super_meta->$metaclass_type;
+
+    # for instance, Moose::Meta::Class has a destructor_class, but
+    # Class::MOP::Class doesn't - this shouldn't be an error
+    return unless defined $super_specific_meta;
+
+    # if metaclass is defined in superclass but not here, it's fixable
+    # this is a really odd case
+    return 1 unless defined $specific_meta;
+
+    return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
+}
+
+sub _fix_class_metaclass_incompatibility {
+    my $self = shift;
+    my ( $super_meta ) = @_;
+
+    if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
+        ($self->is_pristine)
+            || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name => $self->name,
+                                                                   superclass => $super_meta
+                              );
+
+        my $super_meta_name = $super_meta->_real_ref_name;
+
+        $self->_make_compatible_with($super_meta_name);
+    }
+}
+
+sub _fix_single_metaclass_incompatibility {
+    my $self = shift;
+    my ( $metaclass_type, $super_meta ) = @_;
+
+    if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
+        ($self->is_pristine)
+            || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name     => $self->name,
+                                                                   superclass     => $super_meta,
+                                                                   metaclass_type => $metaclass_type
+                              );
+
+        my $new_metaclass = $self->$metaclass_type
+            ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
+            : $super_meta->$metaclass_type;
+        $self->{$metaclass_type} = $new_metaclass;
+    }
+}
+
+sub _restore_metaobjects_from {
+    my $self = shift;
+    my ($old_meta) = @_;
+
+    $self->_restore_metamethods_from($old_meta);
+    $self->_restore_metaattributes_from($old_meta);
+}
+
+sub _remove_generated_metaobjects {
+    my $self = shift;
+
+    for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
+        $attr->remove_accessors;
+    }
+}
+
+# creating classes with MOP ...
+
+sub create {
+    my $class = shift;
+    my @args = @_;
+
+    unshift @args, 'package' if @args % 2 == 1;
+    my %options = @args;
+
+    (ref $options{superclasses} eq 'ARRAY')
+        || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfSuperclasses => class  => $class,
+                                                                         params => \%options
+                          )
+            if exists $options{superclasses};
+
+    (ref $options{attributes} eq 'ARRAY')
+        || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfAttributes => class  => $class,
+                                                                       params => \%options
+                          )
+            if exists $options{attributes};
+
+    (ref $options{methods} eq 'HASH')
+        || __PACKAGE__->_throw_exception( CreateMOPClassTakesHashRefOfMethods => class  => $class,
+                                                                   params => \%options
+                          )
+            if exists $options{methods};
+
+    my $package      = delete $options{package};
+    my $superclasses = delete $options{superclasses};
+    my $attributes   = delete $options{attributes};
+    my $methods      = delete $options{methods};
+    my $meta_name    = exists $options{meta_name}
+                         ? delete $options{meta_name}
+                         : 'meta';
+
+    my $meta = $class->SUPER::create($package => %options);
+
+    $meta->_add_meta_method($meta_name)
+        if defined $meta_name;
+
+    $meta->superclasses(@{$superclasses})
+        if defined $superclasses;
+    # NOTE:
+    # process attributes first, so that they can
+    # install accessors, but locally defined methods
+    # can then overwrite them. It is maybe a little odd, but
+    # I think this should be the order of things.
+    if (defined $attributes) {
+        foreach my $attr (@{$attributes}) {
+            $meta->add_attribute($attr);
+        }
+    }
+    if (defined $methods) {
+        foreach my $method_name (keys %{$methods}) {
+            $meta->add_method($method_name, $methods->{$method_name});
+        }
+    }
+    return $meta;
+}
+
+# XXX: something more intelligent here?
+sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' }
+
+sub create_anon_class { shift->create_anon(@_) }
+sub is_anon_class     { shift->is_anon(@_)     }
+
+sub _anon_cache_key {
+    my $class = shift;
+    my %options = @_;
+    # Makes something like Super::Class|Super::Class::2
+    return join '=' => (
+        join( '|', sort @{ $options{superclasses} || [] } ),
+    );
+}
+
+# Instance Construction & Cloning
+
+sub new_object {
+    my $class = shift;
+
+    # NOTE:
+    # we need to protect the integrity of the
+    # Class::MOP::Class singletons here, so we
+    # delegate this to &construct_class_instance
+    # which will deal with the singletons
+    return $class->_construct_class_instance(@_)
+        if $class->name->isa('Class::MOP::Class');
+    return $class->_construct_instance(@_);
+}
+
+sub _construct_instance {
+    my $class = shift;
+    my $params = @_ == 1 ? $_[0] : {@_};
+    my $meta_instance = $class->get_meta_instance();
+    # FIXME:
+    # the code below is almost certainly incorrect
+    # but this is foreign inheritance, so we might
+    # have to kludge it in the end.
+    my $instance;
+    if (my $instance_class = blessed($params->{__INSTANCE__})) {
+        ($instance_class eq $class->name)
+            || $class->_throw_exception( InstanceBlessedIntoWrongClass => class_name => $class->name,
+                                                                 params     => $params,
+                                                                 instance   => $params->{__INSTANCE__}
+                              );
+        $instance = $params->{__INSTANCE__};
+    }
+    elsif (exists $params->{__INSTANCE__}) {
+        $class->_throw_exception( InstanceMustBeABlessedReference => class_name => $class->name,
+                                                            params     => $params,
+                                                            instance   => $params->{__INSTANCE__}
+                       );
+    }
+    else {
+        $instance = $meta_instance->create_instance();
+    }
+    foreach my $attr ($class->get_all_attributes()) {
+        $attr->initialize_instance_slot($meta_instance, $instance, $params);
+    }
+    if (Class::MOP::metaclass_is_weak($class->name)) {
+        $meta_instance->_set_mop_slot($instance, $class);
+    }
+    return $instance;
+}
+
+sub _inline_new_object {
+    my $self = shift;
+
+    return (
+        'my $class = shift;',
+        '$class = Scalar::Util::blessed($class) || $class;',
+        $self->_inline_fallback_constructor('$class'),
+        $self->_inline_params('$params', '$class'),
+        $self->_inline_generate_instance('$instance', '$class'),
+        $self->_inline_slot_initializers,
+        $self->_inline_preserve_weak_metaclasses,
+        $self->_inline_extra_init,
+        'return $instance',
+    );
+}
+
+sub _inline_fallback_constructor {
+    my $self = shift;
+    my ($class) = @_;
+    return (
+        'return ' . $self->_generate_fallback_constructor($class),
+            'if ' . $class . ' ne \'' . $self->name . '\';',
+    );
+}
+
+sub _generate_fallback_constructor {
+    my $self = shift;
+    my ($class) = @_;
+    return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)',
+}
+
+sub _inline_params {
+    my $self = shift;
+    my ($params, $class) = @_;
+    return (
+        'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};',
+    );
+}
+
+sub _inline_generate_instance {
+    my $self = shift;
+    my ($inst, $class) = @_;
+    return (
+        'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';',
+    );
+}
+
+sub _inline_create_instance {
+    my $self = shift;
+
+    return $self->get_meta_instance->inline_create_instance(@_);
+}
+
+sub _inline_slot_initializers {
+    my $self = shift;
+
+    my $idx = 0;
+
+    return map { $self->_inline_slot_initializer($_, $idx++) }
+               sort { $a->name cmp $b->name } $self->get_all_attributes;
+}
+
+sub _inline_slot_initializer {
+    my $self  = shift;
+    my ($attr, $idx) = @_;
+
+    if (defined(my $init_arg = $attr->init_arg)) {
+        my @source = (
+            'if (exists $params->{\'' . $init_arg . '\'}) {',
+                $self->_inline_init_attr_from_constructor($attr, $idx),
+            '}',
+        );
+        if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
+            push @source, (
+                'else {',
+                    @default,
+                '}',
+            );
+        }
+        return @source;
+    }
+    elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
+        return (
+            '{',
+                @default,
+            '}',
+        );
+    }
+    else {
+        return ();
+    }
+}
+
+sub _inline_init_attr_from_constructor {
+    my $self = shift;
+    my ($attr, $idx) = @_;
+
+    my @initial_value = $attr->_inline_set_value(
+        '$instance', '$params->{\'' . $attr->init_arg . '\'}',
+    );
+
+    push @initial_value, (
+        '$attrs->[' . $idx . ']->set_initial_value(',
+            '$instance,',
+            $attr->_inline_instance_get('$instance'),
+        ');',
+    ) if $attr->has_initializer;
+
+    return @initial_value;
+}
+
+sub _inline_init_attr_from_default {
+    my $self = shift;
+    my ($attr, $idx) = @_;
+
+    my $default = $self->_inline_default_value($attr, $idx);
+    return unless $default;
+
+    my @initial_value = $attr->_inline_set_value('$instance', $default);
+
+    push @initial_value, (
+        '$attrs->[' . $idx . ']->set_initial_value(',
+            '$instance,',
+            $attr->_inline_instance_get('$instance'),
+        ');',
+    ) if $attr->has_initializer;
+
+    return @initial_value;
+}
+
+sub _inline_default_value {
+    my $self = shift;
+    my ($attr, $index) = @_;
+
+    if ($attr->has_default) {
+        # NOTE:
+        # default values can either be CODE refs
+        # in which case we need to call them. Or
+        # they can be scalars (strings/numbers)
+        # in which case we can just deal with them
+        # in the code we eval.
+        if ($attr->is_default_a_coderef) {
+            return '$defaults->[' . $index . ']->($instance)';
+        }
+        else {
+            return '$defaults->[' . $index . ']';
+        }
+    }
+    elsif ($attr->has_builder) {
+        return '$instance->' . $attr->builder;
+    }
+    else {
+        return;
+    }
+}
+
+sub _inline_preserve_weak_metaclasses {
+    my $self = shift;
+    if (Class::MOP::metaclass_is_weak($self->name)) {
+        return (
+            $self->_inline_set_mop_slot(
+                '$instance', 'Class::MOP::class_of($class)'
+            ) . ';'
+        );
+    }
+    else {
+        return ();
+    }
+}
+
+sub _inline_extra_init { }
+
+sub _eval_environment {
+    my $self = shift;
+
+    my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
+
+    my $defaults = [map { $_->default } @attrs];
+
+    return {
+        '$defaults' => \$defaults,
+    };
+}
+
+
+sub get_meta_instance {
+    my $self = shift;
+    $self->{'_meta_instance'} ||= $self->_create_meta_instance();
+}
+
+sub _create_meta_instance {
+    my $self = shift;
+
+    my $instance = $self->instance_metaclass->new(
+        associated_metaclass => $self,
+        attributes => [ $self->get_all_attributes() ],
+    );
+
+    $self->add_meta_instance_dependencies()
+        if $instance->is_dependent_on_superclasses();
+
+    return $instance;
+}
+
+# TODO: this is actually not being used!
+sub _inline_rebless_instance {
+    my $self = shift;
+
+    return $self->get_meta_instance->inline_rebless_instance_structure(@_);
+}
+
+sub _inline_get_mop_slot {
+    my $self = shift;
+
+    return $self->get_meta_instance->_inline_get_mop_slot(@_);
+}
+
+sub _inline_set_mop_slot {
+    my $self = shift;
+
+    return $self->get_meta_instance->_inline_set_mop_slot(@_);
+}
+
+sub _inline_clear_mop_slot {
+    my $self = shift;
+
+    return $self->get_meta_instance->_inline_clear_mop_slot(@_);
+}
+
+sub clone_object {
+    my $class    = shift;
+    my $instance = shift;
+    (blessed($instance) && $instance->isa($class->name))
+        || $class->_throw_exception( CloneObjectExpectsAnInstanceOfMetaclass => class_name => $class->name,
+                                                                       instance   => $instance,
+                          );
+    # NOTE:
+    # we need to protect the integrity of the
+    # Class::MOP::Class singletons here, they
+    # should not be cloned.
+    return $instance if $instance->isa('Class::MOP::Class');
+    $class->_clone_instance($instance, @_);
+}
+
+sub _clone_instance {
+    my ($class, $instance, %params) = @_;
+    (blessed($instance))
+        || $class->_throw_exception( OnlyInstancesCanBeCloned => class_name => $class->name,
+                                                        instance   => $instance,
+                                                        params     => \%params
+                          );
+    my $meta_instance = $class->get_meta_instance();
+    my $clone = $meta_instance->clone_instance($instance);
+    foreach my $attr ($class->get_all_attributes()) {
+        if ( defined( my $init_arg = $attr->init_arg ) ) {
+            if (exists $params{$init_arg}) {
+                $attr->set_value($clone, $params{$init_arg});
+            }
+        }
+    }
+    return $clone;
+}
+
+sub _force_rebless_instance {
+    my ($self, $instance, %params) = @_;
+    my $old_metaclass = Class::MOP::class_of($instance);
+
+    $old_metaclass->rebless_instance_away($instance, $self, %params)
+        if $old_metaclass;
+
+    my $meta_instance = $self->get_meta_instance;
+
+    if (Class::MOP::metaclass_is_weak($old_metaclass->name)) {
+        $meta_instance->_clear_mop_slot($instance);
+    }
+
+    # rebless!
+    # we use $_[1] here because of t/cmop/rebless_overload.t regressions
+    # on 5.8.8
+    $meta_instance->rebless_instance_structure($_[1], $self);
+
+    $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
+
+    if (Class::MOP::metaclass_is_weak($self->name)) {
+        $meta_instance->_set_mop_slot($instance, $self);
+    }
+}
+
+sub rebless_instance {
+    my ($self, $instance, %params) = @_;
+    my $old_metaclass = Class::MOP::class_of($instance);
+
+    my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
+    $self->name->isa($old_class)
+        || $self->_throw_exception( CanReblessOnlyIntoASubclass => class_name     => $self->name,
+                                                           instance       => $instance,
+                                                           instance_class => blessed( $instance ),
+                                                           params         => \%params,
+                          );
+
+    $self->_force_rebless_instance($_[1], %params);
+
+    return $instance;
+}
+
+sub rebless_instance_back {
+    my ( $self, $instance ) = @_;
+    my $old_metaclass = Class::MOP::class_of($instance);
+    my $old_class
+        = $old_metaclass ? $old_metaclass->name : blessed($instance);
+    $old_class->isa( $self->name )
+        || $self->_throw_exception( CanReblessOnlyIntoASuperclass => class_name     => $self->name,
+                                                             instance       => $instance,
+                                                             instance_class => blessed( $instance ),
+                          );
+
+    $self->_force_rebless_instance($_[1]);
+
+    return $instance;
+}
+
+sub rebless_instance_away {
+    # this intentionally does nothing, it is just a hook
+}
+
+sub _fixup_attributes_after_rebless {
+    my $self = shift;
+    my ($instance, $rebless_from, %params) = @_;
+    my $meta_instance = $self->get_meta_instance;
+
+    for my $attr ( $rebless_from->get_all_attributes ) {
+        next if $self->find_attribute_by_name( $attr->name );
+        $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
+    }
+
+    foreach my $attr ( $self->get_all_attributes ) {
+        if ( $attr->has_value($instance) ) {
+            if ( defined( my $init_arg = $attr->init_arg ) ) {
+                $params{$init_arg} = $attr->get_value($instance)
+                    unless exists $params{$init_arg};
+            }
+            else {
+                $attr->set_value($instance, $attr->get_value($instance));
+            }
+        }
+    }
+
+    foreach my $attr ($self->get_all_attributes) {
+        $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+    }
+}
+
+sub _attach_attribute {
+    my ($self, $attribute) = @_;
+    $attribute->attach_to_class($self);
+}
+
+sub _post_add_attribute {
+    my ( $self, $attribute ) = @_;
+
+    $self->invalidate_meta_instances;
+
+    # invalidate package flag here
+    try {
+        local $SIG{__DIE__};
+        $attribute->install_accessors;
+    }
+    catch {
+        $self->remove_attribute( $attribute->name );
+        die $_;
+    };
+}
+
+sub remove_attribute {
+    my $self = shift;
+
+    my $removed_attribute = $self->SUPER::remove_attribute(@_)
+        or return;
+
+    $self->invalidate_meta_instances;
+
+    $removed_attribute->remove_accessors;
+    $removed_attribute->detach_from_class;
+
+    return$removed_attribute;
+}
+
+sub find_attribute_by_name {
+    my ( $self, $attr_name ) = @_;
+
+    foreach my $class ( $self->linearized_isa ) {
+        # fetch the meta-class ...
+        my $meta = Class::MOP::Class->initialize($class);
+        return $meta->get_attribute($attr_name)
+            if $meta->has_attribute($attr_name);
+    }
+
+    return;
+}
+
+sub get_all_attributes {
+    my $self = shift;
+    my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
+        reverse $self->linearized_isa;
+    return values %attrs;
+}
+
+# Inheritance
+
+sub superclasses {
+    my $self     = shift;
+
+    my $isa = $self->get_or_add_package_symbol('@ISA');
+
+    if (@_) {
+        my @supers = @_;
+        @{$isa} = @supers;
+
+        # NOTE:
+        # on 5.8 and below, we need to call
+        # a method to get Perl to detect
+        # a cycle in the class hierarchy
+        my $class = $self->name;
+        $class->isa($class);
+
+        # NOTE:
+        # we need to check the metaclass
+        # compatibility here so that we can
+        # be sure that the superclass is
+        # not potentially creating an issues
+        # we don't know about
+
+        $self->_check_metaclass_compatibility();
+        $self->_superclasses_updated();
+    }
+
+    return @{$isa};
+}
+
+sub _superclasses_updated {
+    my $self = shift;
+    $self->update_meta_instance_dependencies();
+    # keep strong references to all our parents, so they don't disappear if
+    # they are anon classes and don't have any direct instances
+    $self->_superclass_metas(
+        map { Class::MOP::class_of($_) } $self->superclasses
+    );
+}
+
+sub _superclass_metas {
+    my $self = shift;
+    $self->{_superclass_metas} = [@_];
+}
+
+sub subclasses {
+    my $self = shift;
+    my $super_class = $self->name;
+
+    return @{ $super_class->mro::get_isarev() };
+}
+
+sub direct_subclasses {
+    my $self = shift;
+    my $super_class = $self->name;
+
+    return grep {
+        grep {
+            $_ eq $super_class
+        } Class::MOP::Class->initialize($_)->superclasses
+    } $self->subclasses;
+}
+
+sub linearized_isa {
+    return @{ mro::get_linear_isa( (shift)->name ) };
+}
+
+sub class_precedence_list {
+    my $self = shift;
+    my $name = $self->name;
+
+    unless (Class::MOP::IS_RUNNING_ON_5_10()) {
+        # NOTE:
+        # We need to check for circular inheritance here
+        # if we are not on 5.10, cause 5.8 detects it late.
+        # This will do nothing if all is well, and blow up
+        # otherwise. Yes, it's an ugly hack, better
+        # suggestions are welcome.
+        # - SL
+        ($name || return)->isa('This is a test for circular inheritance')
+    }
+
+    # if our mro is c3, we can
+    # just grab the linear_isa
+    if (mro::get_mro($name) eq 'c3') {
+        return @{ mro::get_linear_isa($name) }
+    }
+    else {
+        # NOTE:
+        # we can't grab the linear_isa for dfs
+        # since it has all the duplicates
+        # already removed.
+        return (
+            $name,
+            map {
+                Class::MOP::Class->initialize($_)->class_precedence_list()
+            } $self->superclasses()
+        );
+    }
+}
+
+sub _method_lookup_order {
+    return (shift->linearized_isa, 'UNIVERSAL');
+}
+
+## Methods
+
+{
+    my $fetch_and_prepare_method = sub {
+        my ($self, $method_name) = @_;
+        my $wrapped_metaclass = $self->wrapped_method_metaclass;
+        # fetch it locally
+        my $method = $self->get_method($method_name);
+        # if we don't have local ...
+        unless ($method) {
+            # try to find the next method
+            $method = $self->find_next_method_by_name($method_name);
+            # die if it does not exist
+            (defined $method)
+                || $self->_throw_exception( MethodNameNotFoundInInheritanceHierarchy => class_name  => $self->name,
+                                                                                method_name => $method_name
+                                  );
+            # and now make sure to wrap it
+            # even if it is already wrapped
+            # because we need a new sub ref
+            $method = $wrapped_metaclass->wrap($method,
+                package_name => $self->name,
+                name         => $method_name,
+            );
+        }
+        else {
+            # now make sure we wrap it properly
+            $method = $wrapped_metaclass->wrap($method,
+                package_name => $self->name,
+                name         => $method_name,
+            ) unless $method->isa($wrapped_metaclass);
+        }
+        $self->add_method($method_name => $method);
+        return $method;
+    };
+
+    sub add_before_method_modifier {
+        my ($self, $method_name, $method_modifier) = @_;
+        (defined $method_name && length $method_name)
+            || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name );
+        my $method = $fetch_and_prepare_method->($self, $method_name);
+        $method->add_before_modifier(
+            subname(':before' => $method_modifier)
+        );
+    }
+
+    sub add_after_method_modifier {
+        my ($self, $method_name, $method_modifier) = @_;
+        (defined $method_name && length $method_name)
+            || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name );
+        my $method = $fetch_and_prepare_method->($self, $method_name);
+        $method->add_after_modifier(
+            subname(':after' => $method_modifier)
+        );
+    }
+
+    sub add_around_method_modifier {
+        my ($self, $method_name, $method_modifier) = @_;
+        (defined $method_name && length $method_name)
+            || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name );
+        my $method = $fetch_and_prepare_method->($self, $method_name);
+        $method->add_around_modifier(
+            subname(':around' => $method_modifier)
+        );
+    }
+
+    # NOTE:
+    # the methods above used to be named like this:
+    #    ${pkg}::${method}:(before|after|around)
+    # but this proved problematic when using one modifier
+    # to wrap multiple methods (something which is likely
+    # to happen pretty regularly IMO). So instead of naming
+    # it like this, I have chosen to just name them purely
+    # with their modifier names, like so:
+    #    :(before|after|around)
+    # The fact is that in a stack trace, it will be fairly
+    # evident from the context what method they are attached
+    # to, and so don't need the fully qualified name.
+}
+
+sub find_method_by_name {
+    my ($self, $method_name) = @_;
+    (defined $method_name && length $method_name)
+        || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name );
+    foreach my $class ($self->_method_lookup_order) {
+        my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
+        return $method if defined $method;
+    }
+    return;
+}
+
+sub get_all_methods {
+    my $self = shift;
+
+    my %methods;
+    for my $class ( reverse $self->_method_lookup_order ) {
+        my $meta = Class::MOP::Class->initialize($class);
+
+        $methods{ $_->name } = $_ for $meta->_get_local_methods;
+    }
+
+    return values %methods;
+}
+
+sub get_all_method_names {
+    my $self = shift;
+    map { $_->name } $self->get_all_methods;
+}
+
+sub find_all_methods_by_name {
+    my ($self, $method_name) = @_;
+    (defined $method_name && length $method_name)
+        || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name );
+    my @methods;
+    foreach my $class ($self->_method_lookup_order) {
+        # fetch the meta-class ...
+        my $meta = Class::MOP::Class->initialize($class);
+        push @methods => {
+            name  => $method_name,
+            class => $class,
+            code  => $meta->get_method($method_name)
+        } if $meta->has_method($method_name);
+    }
+    return @methods;
+}
+
+sub find_next_method_by_name {
+    my ($self, $method_name) = @_;
+    (defined $method_name && length $method_name)
+        || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name );
+    my @cpl = ($self->_method_lookup_order);
+    shift @cpl; # discard ourselves
+    foreach my $class (@cpl) {
+        my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
+        return $method if defined $method;
+    }
+    return;
+}
+
+sub update_meta_instance_dependencies {
+    my $self = shift;
+
+    if ( $self->{meta_instance_dependencies} ) {
+        return $self->add_meta_instance_dependencies;
+    }
+}
+
+sub add_meta_instance_dependencies {
+    my $self = shift;
+
+    $self->remove_meta_instance_dependencies;
+
+    my @attrs = $self->get_all_attributes();
+
+    my %seen;
+    my @classes = grep { not $seen{ $_->name }++ }
+        map { $_->associated_class } @attrs;
+
+    foreach my $class (@classes) {
+        $class->add_dependent_meta_instance($self);
+    }
+
+    $self->{meta_instance_dependencies} = \@classes;
+}
+
+sub remove_meta_instance_dependencies {
+    my $self = shift;
+
+    if ( my $classes = delete $self->{meta_instance_dependencies} ) {
+        foreach my $class (@$classes) {
+            $class->remove_dependent_meta_instance($self);
+        }
+
+        return $classes;
+    }
+
+    return;
+
+}
+
+sub add_dependent_meta_instance {
+    my ( $self, $metaclass ) = @_;
+    push @{ $self->{dependent_meta_instances} }, $metaclass;
+}
+
+sub remove_dependent_meta_instance {
+    my ( $self, $metaclass ) = @_;
+    my $name = $metaclass->name;
+    @$_ = grep { $_->name ne $name } @$_
+        for $self->{dependent_meta_instances};
+}
+
+sub invalidate_meta_instances {
+    my $self = shift;
+    $_->invalidate_meta_instance()
+        for $self, @{ $self->{dependent_meta_instances} };
+}
+
+sub invalidate_meta_instance {
+    my $self = shift;
+    undef $self->{_meta_instance};
+}
+
+# check if we can reinitialize
+sub is_pristine {
+    my $self = shift;
+
+    # if any local attr is defined
+    return if $self->get_attribute_list;
+
+    # or any non-declared methods
+    for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
+        return if $method->isa("Class::MOP::Method::Generated");
+        # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
+    }
+
+    return 1;
+}
+
+## Class closing
+
+sub is_mutable   { 1 }
+sub is_immutable { 0 }
+
+sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
+
+sub _immutable_options {
+    my ( $self, @args ) = @_;
+
+    return (
+        inline_accessors   => 1,
+        inline_constructor => 1,
+        inline_destructor  => 0,
+        debug              => 0,
+        immutable_trait    => $self->immutable_trait,
+        constructor_name   => $self->constructor_name,
+        constructor_class  => $self->constructor_class,
+        destructor_class   => $self->destructor_class,
+        @args,
+    );
+}
+
+sub make_immutable {
+    my ( $self, @args ) = @_;
+
+    return $self unless $self->is_mutable;
+
+    my ($file, $line) = (caller)[1..2];
+
+    $self->_initialize_immutable(
+        file => $file,
+        line => $line,
+        $self->_immutable_options(@args),
+    );
+    $self->_rebless_as_immutable(@args);
+
+    return $self;
+}
+
+sub make_mutable {
+    my $self = shift;
+
+    if ( $self->is_immutable ) {
+        my @args = $self->immutable_options;
+        $self->_rebless_as_mutable();
+        $self->_remove_inlined_code(@args);
+        delete $self->{__immutable};
+        return $self;
+    }
+    else {
+        return;
+    }
+}
+
+sub _rebless_as_immutable {
+    my ( $self, @args ) = @_;
+
+    $self->{__immutable}{original_class} = ref $self;
+
+    bless $self => $self->_immutable_metaclass(@args);
+}
+
+sub _immutable_metaclass {
+    my ( $self, %args ) = @_;
+
+    if ( my $class = $args{immutable_metaclass} ) {
+        return $class;
+    }
+
+    my $trait = $args{immutable_trait} = $self->immutable_trait
+        || $self->_throw_exception( NoImmutableTraitSpecifiedForClass => class_name => $self->name,
+                                                                 params     => \%args
+                          );
+
+    my $meta      = $self->meta;
+    my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
+
+    my $class_name;
+
+    if ( $meta_attr and $trait eq $meta_attr->default ) {
+        # if the trait is the same as the default we try and pick a
+        # predictable name for the immutable metaclass
+        $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
+    }
+    else {
+        $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
+            $trait, 'ForMetaClass', ref($self);
+    }
+
+    return $class_name
+        if Class::MOP::does_metaclass_exist($class_name);
+
+    # If the metaclass is a subclass of CMOP::Class which has had
+    # metaclass roles applied (via Moose), then we want to make sure
+    # that we preserve that anonymous class (see Fey::ORM for an
+    # example of where this matters).
+    my $meta_name = $meta->_real_ref_name;
+
+    my $immutable_meta = $meta_name->create(
+        $class_name,
+        superclasses => [ ref $self ],
+    );
+
+    Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
+
+    $immutable_meta->make_immutable(
+        inline_constructor => 0,
+        inline_accessors   => 0,
+    );
+
+    return $class_name;
+}
+
+sub _remove_inlined_code {
+    my $self = shift;
+
+    $self->remove_method( $_->name ) for $self->_inlined_methods;
+
+    delete $self->{__immutable}{inlined_methods};
+}
+
+sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
+
+sub _add_inlined_method {
+    my ( $self, $method ) = @_;
+
+    push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
+}
+
+sub _initialize_immutable {
+    my ( $self, %args ) = @_;
+
+    $self->{__immutable}{options} = \%args;
+    $self->_install_inlined_code(%args);
+}
+
+sub _install_inlined_code {
+    my ( $self, %args ) = @_;
+
+    # FIXME
+    $self->_inline_accessors(%args)   if $args{inline_accessors};
+    $self->_inline_constructor(%args) if $args{inline_constructor};
+    $self->_inline_destructor(%args)  if $args{inline_destructor};
+}
+
+sub _rebless_as_mutable {
+    my $self = shift;
+
+    bless $self, $self->_get_mutable_metaclass_name;
+
+    return $self;
+}
+
+sub _inline_accessors {
+    my $self = shift;
+
+    foreach my $attr_name ( $self->get_attribute_list ) {
+        $self->get_attribute($attr_name)->install_accessors(1);
+    }
+}
+
+sub _inline_constructor {
+    my ( $self, %args ) = @_;
+
+    my $name = $args{constructor_name};
+    # A class may not even have a constructor, and that's okay.
+    return unless defined $name;
+
+    if ( $self->has_method($name) && !$args{replace_constructor} ) {
+        my $class = $self->name;
+        warn "Not inlining a constructor for $class since it defines"
+            . " its own constructor.\n"
+            . "If you are certain you don't need to inline your"
+            . " constructor, specify inline_constructor => 0 in your"
+            . " call to $class->meta->make_immutable\n";
+        return;
+    }
+
+    my $constructor_class = $args{constructor_class};
+
+    {
+        local $@;
+        use_package_optimistically($constructor_class);
+    }
+
+    my $constructor = $constructor_class->new(
+        options      => \%args,
+        metaclass    => $self,
+        is_inline    => 1,
+        package_name => $self->name,
+        name         => $name,
+        definition_context => {
+            description => "constructor " . $self->name . "::" . $name,
+            file        => $args{file},
+            line        => $args{line},
+        },
+    );
+
+    if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
+        $self->add_method( $name => $constructor );
+        $self->_add_inlined_method($constructor);
+    }
+}
+
+sub _inline_destructor {
+    my ( $self, %args ) = @_;
+
+    ( exists $args{destructor_class} && defined $args{destructor_class} )
+        || $self->_throw_exception( NoDestructorClassSpecified => class_name => $self->name,
+                                                          params     => \%args,
+                          );
+
+    if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
+        my $class = $self->name;
+        warn "Not inlining a destructor for $class since it defines"
+            . " its own destructor.\n";
+        return;
+    }
+
+    my $destructor_class = $args{destructor_class};
+
+    {
+        local $@;
+        use_package_optimistically($destructor_class);
+    }
+
+    return unless $destructor_class->is_needed($self);
+
+    my $destructor = $destructor_class->new(
+        options      => \%args,
+        metaclass    => $self,
+        package_name => $self->name,
+        name         => 'DESTROY',
+        definition_context => {
+            description => "destructor " . $self->name . "::DESTROY",
+            file        => $args{file},
+            line        => $args{line},
+        },
+    );
+
+    if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
+        $self->add_method( 'DESTROY' => $destructor );
+        $self->_add_inlined_method($destructor);
+    }
+}
+
+1;
+
+# ABSTRACT: Class Meta Object
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Class - Class Meta Object
+
+=head1 VERSION
+
+version 2.1405
+
+=head1 SYNOPSIS
+
+  # assuming that class Foo
+  # has been defined, you can
+
+  # use this for introspection ...
+
+  # add a method to Foo ...
+  Foo->meta->add_method( 'bar' => sub {...} )
+
+  # get a list of all the classes searched
+  # the method dispatcher in the correct order
+  Foo->meta->class_precedence_list()
+
+  # remove a method from Foo
+  Foo->meta->remove_method('bar');
+
+  # or use this to actually create classes ...
+
+  Class::MOP::Class->create(
+      'Bar' => (
+          version      => '0.01',
+          superclasses => ['Foo'],
+          attributes   => [
+              Class::MOP::Attribute->new('$bar'),
+              Class::MOP::Attribute->new('$baz'),
+          ],
+          methods => {
+              calculate_bar => sub {...},
+              construct_baz => sub {...}
+          }
+      )
+  );
+
+=head1 DESCRIPTION
+
+The Class Protocol is the largest and most complex part of the
+Class::MOP meta-object protocol. It controls the introspection and
+manipulation of Perl 5 classes, and it can create them as well. The
+best way to understand what this module can do is to read the
+documentation for each of its methods.
+
+=head1 INHERITANCE
+
+C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
+
+=head1 METHODS
+
+=head2 Class construction
+
+These methods all create new C<Class::MOP::Class> objects. These
+objects can represent existing classes or they can be used to create
+new classes from scratch.
+
+The metaclass object for a given class is a singleton. If you attempt
+to create a metaclass for the same class twice, you will just get the
+existing object.
+
+=over 4
+
+=item B<< Class::MOP::Class->create($package_name, %options) >>
+
+This method creates a new C<Class::MOP::Class> object with the given
+package name. It accepts a number of options:
+
+=over 8
+
+=item * version
+
+An optional version number for the newly created package.
+
+=item * authority
+
+An optional authority for the newly created package.
+See L<Class::MOP::Module/authority> for more details.
+
+=item * superclasses
+
+An optional array reference of superclass names.
+
+=item * methods
+
+An optional hash reference of methods for the class. The keys of the
+hash reference are method names and values are subroutine references.
+
+=item * attributes
+
+An optional array reference of L<Class::MOP::Attribute> objects.
+
+=item * meta_name
+
+Specifies the name to install the C<meta> method for this class under.
+If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
+given, no meta method will be installed.
+
+=item * weaken
+
+If true, the metaclass that is stored in the global cache will be a
+weak reference.
+
+Classes created in this way are destroyed once the metaclass they are
+attached to goes out of scope, and will be removed from Perl's internal
+symbol table.
+
+All instances of a class with a weakened metaclass keep a special
+reference to the metaclass object, which prevents the metaclass from
+going out of scope while any instances exist.
+
+This only works if the instance is based on a hash reference, however.
+
+=back
+
+=item B<< Class::MOP::Class->create_anon_class(%options) >>
+
+This method works just like C<< Class::MOP::Class->create >> but it
+creates an "anonymous" class. In fact, the class does have a name, but
+that name is a unique name generated internally by this module.
+
+It accepts the same C<superclasses>, C<methods>, and C<attributes>
+parameters that C<create> accepts.
+
+It also accepts a C<cache> option. If this is C<true>, then the anonymous class
+will be cached based on its superclasses and roles. If an existing anonymous
+class in the cache has the same superclasses and roles, it will be reused.
+
+Anonymous classes default to C<< weaken => 1 >> if cache is C<false>, although
+this can be overridden.
+
+=item B<< Class::MOP::Class->initialize($package_name, %options) >>
+
+This method will initialize a C<Class::MOP::Class> object for the
+named package. Unlike C<create>, this method I<will not> create a new
+class.
+
+The purpose of this method is to retrieve a C<Class::MOP::Class>
+object for introspecting an existing class.
+
+If an existing C<Class::MOP::Class> object exists for the named
+package, it will be returned, and any options provided will be
+ignored!
+
+If the object does not yet exist, it will be created.
+
+The valid options that can be passed to this method are
+C<attribute_metaclass>, C<method_metaclass>,
+C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
+optional, and default to the appropriate class in the C<Class::MOP>
+distribution.
+
+=back
+
+=head2 Object instance construction and cloning
+
+These methods are all related to creating and/or cloning object
+instances.
+
+=over 4
+
+=item B<< $metaclass->clone_object($instance, %params) >>
+
+This method clones an existing object instance. Any parameters you
+provide are will override existing attribute values in the object.
+
+This is a convenience method for cloning an object instance, then
+blessing it into the appropriate package.
+
+You could implement a clone method in your class, using this method:
+
+  sub clone {
+      my ($self, %params) = @_;
+      $self->meta->clone_object($self, %params);
+  }
+
+=item B<< $metaclass->rebless_instance($instance, %params) >>
+
+This method changes the class of C<$instance> to the metaclass's class.
+
+You can only rebless an instance into a subclass of its current
+class. If you pass any additional parameters, these will be treated
+like constructor parameters and used to initialize the object's
+attributes. Any existing attributes that are already set will be
+overwritten.
+
+Before reblessing the instance, this method will call
+C<rebless_instance_away> on the instance's current metaclass. This method
+will be passed the instance, the new metaclass, and any parameters
+specified to C<rebless_instance>. By default, C<rebless_instance_away>
+does nothing; it is merely a hook.
+
+=item B<< $metaclass->rebless_instance_back($instance) >>
+
+Does the same thing as C<rebless_instance>, except that you can only
+rebless an instance into one of its superclasses. Any attributes that
+do not exist in the superclass will be deinitialized.
+
+This is a much more dangerous operation than C<rebless_instance>,
+especially when multiple inheritance is involved, so use this carefully!
+
+=item B<< $metaclass->new_object(%params) >>
+
+This method is used to create a new object of the metaclass's
+class. Any parameters you provide are used to initialize the
+instance's attributes. A special C<__INSTANCE__> key can be passed to
+provide an already generated instance, rather than having Class::MOP
+generate it for you. This is mostly useful for using Class::MOP with
+foreign classes which generate instances using their own constructors.
+
+=item B<< $metaclass->instance_metaclass >>
+
+Returns the class name of the instance metaclass. See
+L<Class::MOP::Instance> for more information on the instance
+metaclass.
+
+=item B<< $metaclass->get_meta_instance >>
+
+Returns an instance of the C<instance_metaclass> to be used in the
+construction of a new instance of the class.
+
+=back
+
+=head2 Informational predicates
+
+These are a few predicate methods for asking information about the
+class itself.
+
+=over 4
+
+=item B<< $metaclass->is_anon_class >>
+
+This returns true if the class was created by calling C<<
+Class::MOP::Class->create_anon_class >>.
+
+=item B<< $metaclass->is_mutable >>
+
+This returns true if the class is still mutable.
+
+=item B<< $metaclass->is_immutable >>
+
+This returns true if the class has been made immutable.
+
+=item B<< $metaclass->is_pristine >>
+
+A class is I<not> pristine if it has non-inherited attributes or if it
+has any generated methods.
+
+=back
+
+=head2 Inheritance Relationships
+
+=over 4
+
+=item B<< $metaclass->superclasses(@superclasses) >>
+
+This is a read-write accessor which represents the superclass
+relationships of the metaclass's class.
+
+This is basically sugar around getting and setting C<@ISA>.
+
+=item B<< $metaclass->class_precedence_list >>
+
+This returns a list of all of the class's ancestor classes. The
+classes are returned in method dispatch order.
+
+=item B<< $metaclass->linearized_isa >>
+
+This returns a list based on C<class_precedence_list> but with all
+duplicates removed.
+
+=item B<< $metaclass->subclasses >>
+
+This returns a list of all subclasses for this class, even indirect
+subclasses.
+
+=item B<< $metaclass->direct_subclasses >>
+
+This returns a list of immediate subclasses for this class, which does not
+include indirect subclasses.
+
+=back
+
+=head2 Method introspection and creation
+
+These methods allow you to introspect a class's methods, as well as
+add, remove, or change methods.
+
+Determining what is truly a method in a Perl 5 class requires some
+heuristics (aka guessing).
+
+Methods defined outside the package with a fully qualified name (C<sub
+Package::name { ... }>) will be included. Similarly, methods named
+with a fully qualified name using L<Sub::Name> are also included.
+
+However, we attempt to ignore imported functions.
+
+Ultimately, we are using heuristics to determine what truly is a
+method in a class, and these heuristics may get the wrong answer in
+some edge cases. However, for most "normal" cases the heuristics work
+correctly.
+
+=over 4
+
+=item B<< $metaclass->get_method($method_name) >>
+
+This will return a L<Class::MOP::Method> for the specified
+C<$method_name>. If the class does not have the specified method, it
+returns C<undef>
+
+=item B<< $metaclass->has_method($method_name) >>
+
+Returns a boolean indicating whether or not the class defines the
+named method. It does not include methods inherited from parent
+classes.
+
+=item B<< $metaclass->get_method_list >>
+
+This will return a list of method I<names> for all methods defined in
+this class.
+
+=item B<< $metaclass->add_method($method_name, $method) >>
+
+This method takes a method name and a subroutine reference, and adds
+the method to the class.
+
+The subroutine reference can be a L<Class::MOP::Method>, and you are
+strongly encouraged to pass a meta method object instead of a code
+reference. If you do so, that object gets stored as part of the
+class's method map directly. If not, the meta information will have to
+be recreated later, and may be incorrect.
+
+If you provide a method object, this method will clone that object if
+the object's package name does not match the class name. This lets us
+track the original source of any methods added from other classes
+(notably Moose roles).
+
+=item B<< $metaclass->remove_method($method_name) >>
+
+Remove the named method from the class. This method returns the
+L<Class::MOP::Method> object for the method.
+
+=item B<< $metaclass->method_metaclass >>
+
+Returns the class name of the method metaclass, see
+L<Class::MOP::Method> for more information on the method metaclass.
+
+=item B<< $metaclass->wrapped_method_metaclass >>
+
+Returns the class name of the wrapped method metaclass, see
+L<Class::MOP::Method::Wrapped> for more information on the wrapped
+method metaclass.
+
+=item B<< $metaclass->get_all_methods >>
+
+This will traverse the inheritance hierarchy and return a list of all
+the L<Class::MOP::Method> objects for this class and its parents.
+
+=item B<< $metaclass->find_method_by_name($method_name) >>
+
+This will return a L<Class::MOP::Method> for the specified
+C<$method_name>. If the class does not have the specified method, it
+returns C<undef>
+
+Unlike C<get_method>, this method I<will> look for the named method in
+superclasses.
+
+=item B<< $metaclass->get_all_method_names >>
+
+This will return a list of method I<names> for all of this class's
+methods, including inherited methods.
+
+=item B<< $metaclass->find_all_methods_by_name($method_name) >>
+
+This method looks for the named method in the class and all of its
+parents. It returns every matching method it finds in the inheritance
+tree, so it returns a list of methods.
+
+Each method is returned as a hash reference with three keys. The keys
+are C<name>, C<class>, and C<code>. The C<code> key has a
+L<Class::MOP::Method> object as its value.
+
+The list of methods is distinct.
+
+=item B<< $metaclass->find_next_method_by_name($method_name) >>
+
+This method returns the first method in any superclass matching the
+given name. It is effectively the method that C<SUPER::$method_name>
+would dispatch to.
+
+=back
+
+=head2 Attribute introspection and creation
+
+Because Perl 5 does not have a core concept of attributes in classes,
+we can only return information about attributes which have been added
+via this class's methods. We cannot discover information about
+attributes which are defined in terms of "regular" Perl 5 methods.
+
+=over 4
+
+=item B<< $metaclass->get_attribute($attribute_name) >>
+
+This will return a L<Class::MOP::Attribute> for the specified
+C<$attribute_name>. If the class does not have the specified
+attribute, it returns C<undef>.
+
+NOTE that get_attribute does not search superclasses, for that you
+need to use C<find_attribute_by_name>.
+
+=item B<< $metaclass->has_attribute($attribute_name) >>
+
+Returns a boolean indicating whether or not the class defines the
+named attribute. It does not include attributes inherited from parent
+classes.
+
+=item B<< $metaclass->get_attribute_list >>
+
+This will return a list of attributes I<names> for all attributes
+defined in this class.  Note that this operates on the current class
+only, it does not traverse the inheritance hierarchy.
+
+=item B<< $metaclass->get_all_attributes >>
+
+This will traverse the inheritance hierarchy and return a list of all
+the L<Class::MOP::Attribute> objects for this class and its parents.
+
+=item B<< $metaclass->find_attribute_by_name($attribute_name) >>
+
+This will return a L<Class::MOP::Attribute> for the specified
+C<$attribute_name>. If the class does not have the specified
+attribute, it returns C<undef>.
+
+Unlike C<get_attribute>, this attribute I<will> look for the named
+attribute in superclasses.
+
+=item B<< $metaclass->add_attribute(...) >>
+
+This method accepts either an existing L<Class::MOP::Attribute>
+object or parameters suitable for passing to that class's C<new>
+method.
+
+The attribute provided will be added to the class.
+
+Any accessor methods defined by the attribute will be added to the
+class when the attribute is added.
+
+If an attribute of the same name already exists, the old attribute
+will be removed first.
+
+=item B<< $metaclass->remove_attribute($attribute_name) >>
+
+This will remove the named attribute from the class, and
+L<Class::MOP::Attribute> object.
+
+Removing an attribute also removes any accessor methods defined by the
+attribute.
+
+However, note that removing an attribute will only affect I<future>
+object instances created for this class, not existing instances.
+
+=item B<< $metaclass->attribute_metaclass >>
+
+Returns the class name of the attribute metaclass for this class. By
+default, this is L<Class::MOP::Attribute>.
+
+=back
+
+=head2 Overload introspection and creation
+
+These methods provide an API to the core L<overload> functionality.
+
+=over 4
+
+=item B<< $metaclass->is_overloaded >>
+
+Returns true if overloading is enabled for this class. Corresponds to
+L<overload::Overloaded|overload/Public Functions>.
+
+=item B<< $metaclass->get_overloaded_operator($op) >>
+
+Returns the L<Class::MOP::Overload> object corresponding to the operator named
+C<$op>, if one exists for this class.
+
+=item B<< $metaclass->has_overloaded_operator($op) >>
+
+Returns whether or not the operator C<$op> is overloaded for this class.
+
+=item B<< $metaclass->get_overload_list >>
+
+Returns a list of operator names which have been overloaded (see
+L<overload/Overloadable Operations> for the list of valid operator names).
+
+=item B<< $metaclass->get_all_overloaded_operators >>
+
+Returns a list of L<Class::MOP::Overload> objects corresponding to the
+operators that have been overloaded.
+
+=item B<< $metaclass->add_overloaded_operator($op, $impl) >>
+
+Overloads the operator C<$op> for this class. The C<$impl> can be a coderef, a
+method name, or a L<Class::MOP::Overload> object. Corresponds to
+C<< use overload $op => $impl; >>
+
+=item B<< $metaclass->remove_overloaded_operator($op) >>
+
+Remove overloading for operator C<$op>. Corresponds to C<< no overload $op; >>
+
+=item B<< $metaclass->get_overload_fallback_value >>
+
+Returns the overload C<fallback> setting for the package.
+
+=item B<< $metaclass->set_overload_fallback_value($fallback) >>
+
+Sets the overload C<fallback> setting for the package.
+
+=back
+
+=head2 Class Immutability
+
+Making a class immutable "freezes" the class definition. You can no
+longer call methods which alter the class, such as adding or removing
+methods or attributes.
+
+Making a class immutable lets us optimize the class by inlining some
+methods, and also allows us to optimize some methods on the metaclass
+object itself.
+
+After immutabilization, the metaclass object will cache most informational
+methods that returns information about methods or attributes. Methods which
+would alter the class, such as C<add_attribute> and C<add_method>, will
+throw an error on an immutable metaclass object.
+
+The immutabilization system in L<Moose> takes much greater advantage
+of the inlining features than Class::MOP itself does.
+
+=over 4
+
+=item B<< $metaclass->make_immutable(%options) >>
+
+This method will create an immutable transformer and use it to make
+the class and its metaclass object immutable, and returns true
+(you should not rely on the details of this value apart from its truth).
+
+This method accepts the following options:
+
+=over 8
+
+=item * inline_accessors
+
+=item * inline_constructor
+
+=item * inline_destructor
+
+These are all booleans indicating whether the specified method(s)
+should be inlined.
+
+By default, accessors and the constructor are inlined, but not the
+destructor.
+
+=item * immutable_trait
+
+The name of a class which will be used as a parent class for the
+metaclass object being made immutable. This "trait" implements the
+post-immutability functionality of the metaclass (but not the
+transformation itself).
+
+This defaults to L<Class::MOP::Class::Immutable::Trait>.
+
+=item * constructor_name
+
+This is the constructor method name. This defaults to "new".
+
+=item * constructor_class
+
+The name of the method metaclass for constructors. It will be used to
+generate the inlined constructor. This defaults to
+"Class::MOP::Method::Constructor".
+
+=item * replace_constructor
+
+This is a boolean indicating whether an existing constructor should be
+replaced when inlining a constructor. This defaults to false.
+
+=item * destructor_class
+
+The name of the method metaclass for destructors. It will be used to
+generate the inlined destructor. This defaults to
+"Class::MOP::Method::Denstructor".
+
+=item * replace_destructor
+
+This is a boolean indicating whether an existing destructor should be
+replaced when inlining a destructor. This defaults to false.
+
+=back
+
+=item B<< $metaclass->immutable_options >>
+
+Returns a hash of the options used when making the class immutable, including
+both defaults and anything supplied by the user in the call to C<<
+$metaclass->make_immutable >>. This is useful if you need to temporarily make
+a class mutable and then restore immutability as it was before.
+
+=item B<< $metaclass->make_mutable >>
+
+Calling this method reverse the immutabilization transformation.
+
+=back
+
+=head2 Method Modifiers
+
+Method modifiers are hooks which allow a method to be wrapped with
+I<before>, I<after> and I<around> method modifiers. Every time a
+method is called, its modifiers are also called.
+
+A class can modify its own methods, as well as methods defined in
+parent classes.
+
+=head3 How method modifiers work?
+
+Method modifiers work by wrapping the original method and then
+replacing it in the class's symbol table. The wrappers will handle
+calling all the modifiers in the appropriate order and preserving the
+calling context for the original method.
+
+The return values of C<before> and C<after> modifiers are
+ignored. This is because their purpose is B<not> to filter the input
+and output of the primary method (this is done with an I<around>
+modifier).
+
+This may seem like an odd restriction to some, but doing this allows
+for simple code to be added at the beginning or end of a method call
+without altering the function of the wrapped method or placing any
+extra responsibility on the code of the modifier.
+
+Of course if you have more complex needs, you can use the C<around>
+modifier which allows you to change both the parameters passed to the
+wrapped method, as well as its return value.
+
+Before and around modifiers are called in last-defined-first-called
+order, while after modifiers are called in first-defined-first-called
+order. So the call tree might looks something like this:
+
+  before 2
+   before 1
+    around 2
+     around 1
+      primary
+     around 1
+    around 2
+   after 1
+  after 2
+
+=head3 What is the performance impact?
+
+Of course there is a performance cost associated with method
+modifiers, but we have made every effort to make that cost directly
+proportional to the number of modifier features you use.
+
+The wrapping method does its best to B<only> do as much work as it
+absolutely needs to. In order to do this we have moved some of the
+performance costs to set-up time, where they are easier to amortize.
+
+All this said, our benchmarks have indicated the following:
+
+  simple wrapper with no modifiers             100% slower
+  simple wrapper with simple before modifier   400% slower
+  simple wrapper with simple after modifier    450% slower
+  simple wrapper with simple around modifier   500-550% slower
+  simple wrapper with all 3 modifiers          1100% slower
+
+These numbers may seem daunting, but you must remember, every feature
+comes with some cost. To put things in perspective, just doing a
+simple C<AUTOLOAD> which does nothing but extract the name of the
+method called and return it costs about 400% over a normal method
+call.
+
+=over 4
+
+=item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
+
+This wraps the specified method with the supplied subroutine
+reference. The modifier will be called as a method itself, and will
+receive the same arguments as are passed to the method.
+
+When the modifier exits, the wrapped method will be called.
+
+The return value of the modifier will be ignored.
+
+=item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
+
+This wraps the specified method with the supplied subroutine
+reference. The modifier will be called as a method itself, and will
+receive the same arguments as are passed to the method.
+
+When the wrapped methods exits, the modifier will be called.
+
+The return value of the modifier will be ignored.
+
+=item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
+
+This wraps the specified method with the supplied subroutine
+reference.
+
+The first argument passed to the modifier will be a subroutine
+reference to the wrapped method. The second argument is the object,
+and after that come any arguments passed when the method is called.
+
+The around modifier can choose to call the original method, as well as
+what arguments to pass if it does so.
+
+The return value of the modifier is what will be seen by the caller.
+
+=back
+
+=head2 Introspection
+
+=over 4
+
+=item B<< Class::MOP::Class->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+It should also be noted that L<Class::MOP> will actually bootstrap
+this module by installing a number of attribute meta-objects into its
+metaclass.
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Stevan Little <stevan.little@iinteractive.com>
+
+=item *
+
+Dave Rolsky <autarch@urth.org>
+
+=item *
+
+Jesse Luehrs <doy@tozt.net>
+
+=item *
+
+Shawn M Moore <code@sartak.org>
+
+=item *
+
+יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Florian Ragwitz <rafl@debian.org>
+
+=item *
+
+Hans Dieter Pearcey <hdp@weftsoar.net>
+
+=item *
+
+Chris Prather <chris@prather.org>
+
+=item *
+
+Matt S Trout <mst@shadowcat.co.uk>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2006 by Infinity Interactive, Inc..
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut