use Class::MOP::Method::Wrapped;
use Class::MOP::Method::Accessor;
use Class::MOP::Method::Constructor;
-use Class::MOP::Class::Immutable::Class::MOP::Class;
+use Class::MOP::MiniTrait;
use Carp 'confess';
-use Scalar::Util 'blessed', 'weaken';
+use Scalar::Util 'blessed', 'reftype', 'weaken';
+use Sub::Name 'subname';
+use Devel::GlobalDestruction 'in_global_destruction';
+use Try::Tiny;
+use List::MoreUtils 'all';
-our $VERSION = '0.83';
+our $VERSION = '1.11';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Module';
+use base 'Class::MOP::Module',
+ 'Class::MOP::Mixin::HasAttributes',
+ 'Class::MOP::Mixin::HasMethods';
# Creation
$package_name = $options{package};
}
- (defined $package_name && $package_name && !ref($package_name))
+ ($package_name && !ref($package_name))
|| confess "You must pass a package name and it cannot be blessed";
return Class::MOP::get_metaclass_by_name($package_name)
|| $class->_construct_class_instance(package => $package_name, @_);
}
-sub construct_class_instance {
- Carp::cluck('The construct_class_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_construct_class_instance(@_);
+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)
return $meta;
}
- # NOTE:
- # we need to deal with the possibility
- # of class immutability here, and then
- # get the name of the class appropriately
- $class = (ref($class)
- ? ($class->is_immutable
- ? $class->get_mutable_metaclass_name()
- : ref($class))
- : $class);
+ $class
+ = ref $class
+ ? $class->_real_ref_name
+ : $class;
# now create the metaclass
my $meta;
# NOTE:
# we need to weaken any anon classes
# so that they can call DESTROY properly
- Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class;
+ 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] : {@_};
- bless {
+ return bless {
# inherited from Class::MOP::Package
'package' => $options->{package},
# should not actually have a value associated
# with the slot.
'namespace' => \undef,
+ 'methods' => {},
# inherited from Class::MOP::Module
'version' => \undef,
# defined in Class::MOP::Class
'superclasses' => \undef,
- 'methods' => {},
'attributes' => {},
'attribute_metaclass' =>
( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
}, $class;
}
-sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
-sub update_package_cache_flag {
+## 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;
- # NOTE:
- # we can manually update the cache number
- # since we are actually adding the method
- # to our cache as well. This avoids us
- # having to regenerate the method_map.
- # - SL
- $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
+
+ 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;
+
+ confess "The metaclass of " . $self->name . " ("
+ . (ref($self)) . ")" . " is not compatible with "
+ . "the metaclass of its superclass, "
+ . $superclass_name . " (" . ($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;
-sub check_metaclass_compatibility {
- Carp::cluck('The check_metaclass_compatibility method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_check_metaclass_compatibility(@_);
+ my $super_meta_name = $super_meta->_real_ref_name;
+
+ return $self->_is_compatible_with($super_meta_name);
}
-sub _check_metaclass_compatibility {
+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);
+ my $metaclass_type_name = $metaclass_type;
+ $metaclass_type_name =~ s/_(?:meta)?class$//;
+ $metaclass_type_name =~ s/_/ /g;
+ confess "The $metaclass_type_name metaclass for "
+ . $self->name . " (" . ($self->$metaclass_type)
+ . ")" . " is not compatible with the "
+ . "$metaclass_type_name metaclass of its "
+ . "superclass, $superclass_name ("
+ . ($super_meta->$metaclass_type) . ")";
+ }
+}
- # this is always okay ...
- return if ref($self) eq 'Class::MOP::Class' &&
- $self->instance_metaclass eq 'Class::MOP::Instance';
+sub _single_metaclass_is_compatible {
+ my $self = shift;
+ my ( $metaclass_type, $superclass_name ) = @_;
- my @class_list = $self->linearized_isa;
- shift @class_list; # shift off $self->name
+ my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
+ || return 1;
- foreach my $superclass_name (@class_list) {
- my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next;
+ # 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;
- # NOTE:
- # we need to deal with the possibility
- # of class immutability here, and then
- # get the name of the class appropriately
- my $super_meta_type
- = $super_meta->is_immutable
- ? $super_meta->get_mutable_metaclass_name()
- : ref($super_meta);
-
- ($self->isa($super_meta_type))
- || confess "Class::MOP::class_of(" . $self->name . ") => ("
- . (ref($self)) . ")" . " is not compatible with the " .
- "Class::MOP::class_of(".$superclass_name . ") => ("
- . ($super_meta_type) . ")";
- # NOTE:
- # we also need to check that instance metaclasses
- # are compatibile in the same the class.
- ($self->instance_metaclass->isa($super_meta->instance_metaclass))
- || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
- " is not compatible with the " .
- "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
+ 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)
+ || confess "Can't fix metaclass incompatibility for "
+ . $self->name
+ . " because it is not pristine.";
+
+ 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)
+ || confess "Can't fix metaclass incompatibility for "
+ . $self->name
+ . " because it is not pristine.";
+
+ 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;
}
}
sub is_anon_class {
my $self = shift;
no warnings 'uninitialized';
- $self->name =~ /^$ANON_CLASS_PREFIX/;
+ $self->name =~ /^$ANON_CLASS_PREFIX/o;
}
sub create_anon_class {
my ($class, %options) = @_;
+ $options{weaken} = 1 unless exists $options{weaken};
my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
return $class->create($package_name, %options);
}
sub DESTROY {
my $self = shift;
- return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+ return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
no warnings 'uninitialized';
- return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
+ my $name = $self->name;
+ return unless $name =~ /^$ANON_CLASS_PREFIX/o;
+
# Moose does a weird thing where it replaces the metaclass for
# class when fixing metaclass incompatibility. In that case,
# we don't want to clean out the namespace now. We can detect
# that because Moose will explicitly update the singleton
# cache in Class::MOP.
- my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
+ my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if $current_meta ne $self;
- my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
+ my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
no strict 'refs';
- foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) {
- delete ${$ANON_CLASS_PREFIX . $serial_id}{$key};
- }
- delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'};
+ @{$name . '::ISA'} = ();
+ %{$name . '::'} = ();
+ delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+
+ Class::MOP::remove_metaclass_by_name($name);
}
}
|| confess "You must pass a HASH ref of methods"
if exists $options{methods};
+ $options{meta_name} = 'meta'
+ unless exists $options{meta_name};
+
my (%initialize_options) = @args;
delete @initialize_options{qw(
package
superclasses
attributes
methods
+ meta_name
version
authority
)};
$meta->_instantiate_module( $options{version}, $options{authority} );
- # FIXME totally lame
- $meta->add_method('meta' => sub {
- $class->initialize(ref($_[0]) || $_[0]);
- });
+ $meta->_add_meta_method($options{meta_name})
+ if defined $options{meta_name};
$meta->superclasses(@{$options{superclasses}})
if exists $options{superclasses};
return $meta;
}
-## Attribute readers
-
-# NOTE:
-# all these attribute readers will be bootstrapped
-# away in the Class::MOP bootstrap section
-
-sub get_attribute_map { $_[0]->{'attributes'} }
-sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
-sub method_metaclass { $_[0]->{'method_metaclass'} }
-sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
-sub instance_metaclass { $_[0]->{'instance_metaclass'} }
-sub immutable_trait { $_[0]->{'immutable_trait'} }
-sub constructor_class { $_[0]->{'constructor_class'} }
-sub constructor_name { $_[0]->{'constructor_name'} }
-sub destructor_class { $_[0]->{'destructor_class'} }
-
# Instance Construction & Cloning
sub new_object {
return $class->_construct_instance(@_);
}
-sub construct_instance {
- Carp::cluck('The construct_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_construct_instance(@_);
-}
-
sub _construct_instance {
my $class = shift;
my $params = @_ == 1 ? $_[0] : {@_};
my $meta_instance = $class->get_meta_instance();
- my $instance = $meta_instance->create_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)
+ || confess "Objects passed as the __INSTANCE__ parameter must "
+ . "already be blessed into the correct class, but "
+ . "$params->{__INSTANCE__} is not a " . $class->name;
+ $instance = $params->{__INSTANCE__};
+ }
+ elsif (exists $params->{__INSTANCE__}) {
+ confess "The __INSTANCE__ parameter must be a blessed reference, not "
+ . $params->{__INSTANCE__};
+ }
+ else {
+ $instance = $meta_instance->create_instance();
+ }
foreach my $attr ($class->get_all_attributes()) {
$attr->initialize_instance_slot($meta_instance, $instance, $params);
}
- # NOTE:
- # this will only work for a HASH instance type
- if ($class->is_anon_class) {
- (Scalar::Util::reftype($instance) eq 'HASH')
- || confess "Currently only HASH based instances are supported with instance of anon-classes";
- # NOTE:
- # At some point we should make this official
- # as a reserved slot name, but right now I am
- # going to keep it here.
- # my $RESERVED_MOP_SLOT = '__MOP__';
- $instance->{'__MOP__'} = $class;
+ if (Class::MOP::metaclass_is_weak($class->name)) {
+ $meta_instance->_set_mop_slot($instance, $class);
}
return $instance;
}
$self->{'_meta_instance'} ||= $self->_create_meta_instance();
}
-sub create_meta_instance {
- Carp::cluck('The create_meta_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_create_meta_instance(@_);
-}
-
sub _create_meta_instance {
my $self = shift;
return $instance;
}
+sub inline_create_instance {
+ my $self = shift;
+
+ return $self->get_meta_instance->inline_create_instance(@_);
+}
+
+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;
$class->_clone_instance($instance, @_);
}
-sub clone_instance {
- Carp::cluck('The clone_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_clone_instance(@_);
-}
-
sub _clone_instance {
my ($class, $instance, %params) = @_;
(blessed($instance))
return $clone;
}
-sub rebless_instance {
+sub _force_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)
- || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
-
$old_metaclass->rebless_instance_away($instance, $self, %params)
if $old_metaclass;
- my $meta_instance = $self->get_meta_instance();
+ 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/306_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)
+ || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
+
+ $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 )
+ || confess
+ "You may rebless only into a superclass of ($old_class), of which ("
+ . $self->name
+ . ") isn't.";
+
+ $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);
}
-
- $instance;
}
-sub rebless_instance_away {
- # this intentionally does nothing, it is just a hook
+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 $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
+
+ my $isa = $self->get_or_add_package_symbol('@ISA');
+
if (@_) {
my @supers = @_;
- @{$self->get_package_symbol($var_spec)} = @supers;
+ @{$isa} = @supers;
# NOTE:
# on 5.8 and below, we need to call
# we don't know about
$self->_check_metaclass_compatibility();
- $self->update_meta_instance_dependencies();
+ $self->_superclasses_updated();
}
- @{$self->get_package_symbol($var_spec)};
+
+ 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 {
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 ) };
return (
$name,
map {
- $self->initialize($_)->class_precedence_list()
+ Class::MOP::Class->initialize($_)->class_precedence_list()
} $self->superclasses()
);
}
## Methods
-sub wrap_method_body {
- my ( $self, %args ) = @_;
-
- ('CODE' eq ref $args{body})
- || confess "Your code block must be a CODE reference";
-
- $self->method_metaclass->wrap(
- package_name => $self->name,
- %args,
- );
-}
-
-sub add_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $body;
- if (blessed($method)) {
- $body = $method->body;
- if ($method->package_name ne $self->name) {
- $method = $method->clone(
- package_name => $self->name,
- name => $method_name
- ) if $method->can('clone');
- }
- }
- else {
- $body = $method;
- $method = $self->wrap_method_body( body => $body, name => $method_name );
- }
-
- $method->attach_to_class($self);
-
- # This used to call get_method_map, which meant we would build all
- # the method objects for the class just because we added one
- # method. This is hackier, but quicker too.
- $self->{methods}{$method_name} = $method;
-
- my $full_method_name = ($self->name . '::' . $method_name);
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- Class::MOP::subname($full_method_name => $body)
- );
-}
-
{
my $fetch_and_prepare_method = sub {
my ($self, $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);
+ $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)
- unless $method->isa($wrapped_metaclass);
+ $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 && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_before_modifier(
- Class::MOP::subname(':before' => $method_modifier)
+ subname(':before' => $method_modifier)
);
}
sub add_after_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_after_modifier(
- Class::MOP::subname(':after' => $method_modifier)
+ subname(':after' => $method_modifier)
);
}
sub add_around_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_around_modifier(
- Class::MOP::subname(':around' => $method_modifier)
+ subname(':around' => $method_modifier)
);
}
# to, and so don't need the fully qualified name.
}
-sub alias_method {
- Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
-
- shift->add_method(@_);
-}
-
-sub has_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
-}
-
-sub get_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- return $self->{methods}{$method_name} || $self->get_method_map->{$method_name};
-}
-
-sub remove_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $removed_method = delete $self->get_method_map->{$method_name};
-
- $self->remove_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name }
- );
-
- $removed_method->detach_from_class if $removed_method;
-
- $self->update_package_cache_flag; # still valid, since we just removed the method from the map
-
- return $removed_method;
-}
-
-sub get_method_list {
- my $self = shift;
- keys %{$self->get_method_map};
-}
-
sub find_method_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
foreach my $class ($self->linearized_isa) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_method($method_name)
- if $meta->has_method($method_name);
+ 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 = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa;
- return values %methods;
-}
-sub compute_all_applicable_methods {
- Carp::cluck('The compute_all_applicable_methods method is deprecated.'
- . " Use get_all_methods instead.\n");
+ my %methods;
+ for my $class ( reverse $self->linearized_isa ) {
+ my $meta = Class::MOP::Class->initialize($class);
+
+ $methods{ $_->name } = $_ for $meta->_get_local_methods;
+ }
- return map {
- {
- name => $_->name,
- class => $_->package_name,
- code => $_, # sigh, overloading
- },
- } shift->get_all_methods(@_);
+ return values %methods;
}
sub get_all_method_names {
my $self = shift;
my %uniq;
- grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods;
+ return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
}
sub find_all_methods_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
my @methods;
foreach my $class ($self->linearized_isa) {
# fetch the meta-class ...
- my $meta = $self->initialize($class);
+ my $meta = Class::MOP::Class->initialize($class);
push @methods => {
name => $method_name,
class => $class,
sub find_next_method_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
my @cpl = $self->linearized_isa;
shift @cpl; # discard ourselves
foreach my $class (@cpl) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_method($method_name)
- if $meta->has_method($method_name);
+ my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
+ return $method if defined $method;
}
return;
}
-## Attributes
-
-sub add_attribute {
- my $self = shift;
- # either we have an attribute object already
- # or we need to create one from the args provided
- my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
- # make sure it is derived from the correct type though
- ($attribute->isa('Class::MOP::Attribute'))
- || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
-
- # first we attach our new attribute
- # because it might need certain information
- # about the class which it is attached to
- $attribute->attach_to_class($self);
-
- # then we remove attributes of a conflicting
- # name here so that we can properly detach
- # the old attr object, and remove any
- # accessors it would have generated
- if ( $self->has_attribute($attribute->name) ) {
- $self->remove_attribute($attribute->name);
- } else {
- $self->invalidate_meta_instances();
- }
-
- # then onto installing the new accessors
- $self->get_attribute_map->{$attribute->name} = $attribute;
-
- # invalidate package flag here
- my $e = do { local $@; eval { $attribute->install_accessors() }; $@ };
- if ( $e ) {
- $self->remove_attribute($attribute->name);
- die $e;
- }
-
- return $attribute;
-}
-
sub update_meta_instance_dependencies {
my $self = shift;
my @attrs = $self->get_all_attributes();
my %seen;
- my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs;
+ my @classes = grep { not $seen{ $_->name }++ }
+ map { $_->associated_class } @attrs;
- foreach my $class ( @classes ) {
+ foreach my $class (@classes) {
$class->add_dependent_meta_instance($self);
}
my $self = shift;
if ( my $classes = delete $self->{meta_instance_dependencies} ) {
- foreach my $class ( @$classes ) {
+ foreach my $class (@$classes) {
$class->remove_dependent_meta_instance($self);
}
sub remove_dependent_meta_instance {
my ( $self, $metaclass ) = @_;
my $name = $metaclass->name;
- @$_ = grep { $_->name ne $name } @$_ for $self->{dependent_meta_instances};
+ @$_ = 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} };
+ $_->invalidate_meta_instance()
+ for $self, @{ $self->{dependent_meta_instances} };
}
sub invalidate_meta_instance {
undef $self->{_meta_instance};
}
-sub has_attribute {
- my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
- || confess "You must define an attribute name";
- exists $self->get_attribute_map->{$attribute_name};
-}
-
-sub get_attribute {
- my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
- || confess "You must define an attribute name";
- return $self->get_attribute_map->{$attribute_name}
- # NOTE:
- # this will return undef anyway, so no need ...
- # if $self->has_attribute($attribute_name);
- #return;
-}
-
-sub remove_attribute {
- my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
- || confess "You must define an attribute name";
- my $removed_attribute = $self->get_attribute_map->{$attribute_name};
- return unless defined $removed_attribute;
- delete $self->get_attribute_map->{$attribute_name};
- $self->invalidate_meta_instances();
- $removed_attribute->remove_accessors();
- $removed_attribute->detach_from_class();
- return $removed_attribute;
-}
-
-sub get_attribute_list {
- my $self = shift;
- keys %{$self->get_attribute_map};
-}
-
-sub get_all_attributes {
- my $self = shift;
- my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa;
- return values %attrs;
-}
-
-sub compute_all_applicable_attributes {
- Carp::cluck('The compute_all_applicable_attributes method has been deprecated.'
- . " Use get_all_attributes instead.\n");
-
- shift->get_all_attributes(@_);
-}
-
-sub find_attribute_by_name {
- my ($self, $attr_name) = @_;
- foreach my $class ($self->linearized_isa) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_attribute($attr_name)
- if $meta->has_attribute($attr_name);
- }
- return;
-}
-
# check if we can reinitialize
sub is_pristine {
my $self = shift;
return if $self->get_attribute_list;
# or any non-declared methods
- if ( my @methods = values %{ $self->get_method_map } ) {
- my $metaclass = $self->method_metaclass;
- foreach my $method ( @methods ) {
- return if $method->isa("Class::MOP::Method::Generated");
- # FIXME do we need to enforce this too? return unless $method->isa($metaclass);
- }
+ 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;
sub is_mutable { 1 }
sub is_immutable { 0 }
-sub immutable_transformer { return }
+
+sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
sub _immutable_options {
my ( $self, @args ) = @_;
my $trait = $args{immutable_trait} = $self->immutable_trait
|| confess "no immutable trait specified for $self";
- my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait");
+ 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);
+ # 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) );
+ $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
+ $trait, 'ForMetaClass', ref($self);
}
- if ( Class::MOP::is_class_loaded($class_name) ) {
- if ( $class_name->isa($trait) ) {
- return $class_name;
- }
- else {
- confess
- "$class_name is already defined but does not inherit $trait";
- }
- }
- else {
- my @super = ( $trait, ref($self) );
+ return $class_name
+ if Class::MOP::is_class_loaded($class_name);
- my $meta = Class::MOP::Class->initialize($class_name);
- $meta->superclasses(@super);
+ # 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;
- $meta->make_immutable;
+ my $immutable_meta = $meta_name->create(
+ $class_name,
+ superclasses => [ ref $self ],
+ );
- return $class_name;
- }
+ Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
+
+ $immutable_meta->make_immutable(
+ inline_constructor => 0,
+ inline_accessors => 0,
+ );
+
+ return $class_name;
}
sub _remove_inlined_code {
sub _rebless_as_mutable {
my $self = shift;
- bless $self, $self->get_mutable_metaclass_name;
+ bless $self, $self->_get_mutable_metaclass_name;
return $self;
}
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 ( my $existing = $self->name->can($args{constructor_name}) ) {
- # if ( refaddr($existing) == refaddr(\&Moose::Object::new) ) {
-
- unless ( $args{replace_constructor}
- or !$self->has_method($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"
sub _inline_destructor {
my ( $self, %args ) = @_;
- ( exists $args{destructor_class} )
+ ( exists $args{destructor_class} && defined $args{destructor_class} )
|| confess "The 'inline_destructor' option is present, but "
. "no destructor class was specified";
+ 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};
Class::MOP::load_class($destructor_class);
name => 'DESTROY'
);
- $self->add_method( 'DESTROY' => $destructor );
-
- $self->_add_inlined_method($destructor);
+ if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
+ $self->add_method( 'DESTROY' => $destructor );
+ $self->_add_inlined_method($destructor);
+ }
}
1;
# 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()
+ # 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');
+ # remove a method from Foo
+ Foo->meta->remove_method('bar');
# or use this to actually create classes ...
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
+best way to understand what this module can do is to read the
documentation for each of its methods.
=head1 INHERITANCE
=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
+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
=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.
+package name. It accepts a number of options:
=over 8
=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.
+hash reference are method names and values are subroutine references.
=item * attributes
-An optional array reference of attributes.
+An optional array reference of L<Class::MOP::Attribute> objects.
+
+=item * meta_name
-An attribute can be passed as an existing L<Class::MOP::Attribute>
-object, I<or> or as a hash reference of options which will be passed
-to the attribute metaclass's constructor.
+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
It accepts the same C<superclasses>, C<methods>, and C<attributes>
parameters that C<create> accepts.
-Anonymous classes 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 an anonymous class 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 if based on a hash reference, however.
+Anonymous classes default to C<< weaken => 1 >>, although this can be
+overridden.
=item B<< Class::MOP::Class->initialize($package_name, %options) >>
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.
+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
+Returns the class name of the instance metaclass. See
L<Class::MOP::Instance> for more information on the instance
metaclass.
Returns an instance of the C<instance_metaclass> to be used in the
construction of a new instance of the class.
+=item B<< $metaclass->inline_create_instance($class_var) >>
+
+=item B<< $metaclass->inline_rebless_instance($instance_var, $class_var) >>
+
+These methods takes variable names, and use them to create an inline snippet
+of code that will create a new instance of the class.
+
=back
=head2 Informational predicates
=item B<< $metaclass->subclasses >>
-This returns a list of subclasses for this class.
+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
named method. It does not include methods inherited from parent
classes.
-=item B<< $metaclass->get_method_map >>
-
-Returns a hash reference representing the methods defined in this
-class. The keys are method names and the values are
-L<Class::MOP::Method> objects.
-
=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
given name. It is effectively the method that C<SUPER::$method_name>
would dispatch to.
-=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.
-
=back
=head2 Attribute introspection and creation
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>
+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) >>
named attribute. It does not include attributes inherited from parent
classes.
-=item B<< $metaclass->get_attribute_map >>
-
-Returns a hash reference representing the attributes defined in this
-class. The keys are attribute names and the values are
-L<Class::MOP::Attribute> objects.
-
=item B<< $metaclass->get_attribute_list >>
This will return a list of attributes I<names> for all attributes
-defined in this class.
+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 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>
+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>
+object or parameters suitable for passing to that class's C<new>
method.
The attribute provided will be added to the class.
=item B<< $metaclass->attribute_metaclass >>
Returns the class name of the attribute metaclass for this class. By
-default, this is L<Class::MOP::Attribute>. for more information on
+default, this is L<Class::MOP::Attribute>.
=back
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.
=item B<< $metaclass->make_immutable(%options) >>
-This method will create an immutable transformer and uses it to make
+This method will create an immutable transformer and use it to make
the class and its metaclass object immutable.
-Details of how immutabilization works are in L<Class::MOP::Immutable>
-documentation.
+This method accepts the following options:
-=item B<< $metaclass->make_mutable >>
+=over 8
-Calling this method reverse the immutabilization transformation.
+=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 B<< $metaclass->immutable_transformer >>
+=item * constructor_class
-If the class has been made immutable previously, this returns the
-L<Class::MOP::Immutable> object that was created to do the
-transformation.
+The name of the method metaclass for constructors. It will be used to
+generate the inlined constructor. This defaults to
+"Class::MOP::Method::Constructor".
-If the class was never made immutable, this method will die.
+=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
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, it's modifiers are also called.
+method is called, its modifiers are also called.
A class can modify its own methods, as well as methods defined in
parent classes.
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 utilize.
+proportional to the number of modifier features you use.
-The wrapping method does it's best to B<only> do as much work as it
+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.
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2009 by Infinity Interactive, Inc.
+Copyright 2006-2010 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>