use Try::Tiny;
use List::MoreUtils 'all';
-our $VERSION = '1.08';
+our $VERSION = '1.09';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
|| $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});
+ $old_metaclass->_remove_generated_metaobjects
+ if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
+ my $new_metaclass = $class->SUPER::reinitialize(@args);
+ $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
}
}
-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_type = $super_meta->_real_ref_name;
-
- return $self->isa($super_meta_type);
-}
-
sub _check_class_metaclass_compatibility {
my $self = shift;
my ( $superclass_name ) = @_;
}
}
-sub _single_metaclass_is_compatible {
+sub _class_metaclass_is_compatible {
my $self = shift;
- my ( $metaclass_type, $superclass_name ) = @_;
+ my ( $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;
+ my $super_meta_type = $super_meta->_real_ref_name;
- return $self->$metaclass_type->isa($super_meta->$metaclass_type);
+ return $self->isa($super_meta_type);
}
sub _check_single_metaclass_compatibility {
}
}
-sub _can_fix_class_metaclass_incompatibility_by_subclassing {
- my $self = shift;
- my ($super_meta) = @_;
-
- my $super_meta_type = $super_meta->_real_ref_name;
-
- return $super_meta_type ne blessed($self)
- && $super_meta->isa(blessed($self));
-}
-
-sub _can_fix_single_metaclass_incompatibility_by_subclassing {
+sub _single_metaclass_is_compatible {
my $self = shift;
- my ($metaclass_type, $super_meta) = @_;
+ my ( $metaclass_type, $superclass_name ) = @_;
- my $specific_meta = $self->$metaclass_type;
- return unless $super_meta->can($metaclass_type);
- my $super_specific_meta = $super_meta->$metaclass_type;
+ 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 unless defined $super_specific_meta;
-
- # if metaclass is defined in superclass but not here, it's fixable
+ 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 1 unless defined $specific_meta;
-
- return $specific_meta ne $super_specific_meta
- && $super_specific_meta->isa($specific_meta);
-}
-
-sub _can_fix_metaclass_incompatibility_by_subclassing {
- my $self = shift;
- my ($super_meta) = @_;
-
- return 1 if $self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta);
-
- my %base_metaclass = $self->_base_metaclasses;
- for my $metaclass_type (keys %base_metaclass) {
- return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta);
- }
-
- return;
-}
+ return 0 unless defined $self->$metaclass_type;
-sub _can_fix_metaclass_incompatibility {
- my $self = shift;
- return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+ return $self->$metaclass_type->isa($super_meta->$metaclass_type);
}
sub _fix_metaclass_incompatibility {
}
}
+sub _can_fix_metaclass_incompatibility {
+ my $self = shift;
+ return $self->_can_fix_metaclass_incompatibility_by_subclassing(@_);
+}
+
+sub _can_fix_metaclass_incompatibility_by_subclassing {
+ my $self = shift;
+ my ($super_meta) = @_;
+
+ return 1 if $self->_can_fix_class_metaclass_incompatibility_by_subclassing($super_meta);
+
+ my %base_metaclass = $self->_base_metaclasses;
+ for my $metaclass_type (keys %base_metaclass) {
+ return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta);
+ }
+
+ return;
+}
+
+sub _can_fix_class_metaclass_incompatibility_by_subclassing {
+ my $self = shift;
+ my ($super_meta) = @_;
+
+ my $super_meta_type = $super_meta->_real_ref_name;
+
+ return $super_meta_type ne blessed($self)
+ && $super_meta->isa(blessed($self));
+}
+
+sub _can_fix_single_metaclass_incompatibility_by_subclassing {
+ my $self = shift;
+ my ($metaclass_type, $super_meta) = @_;
+
+ 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 $specific_meta ne $super_specific_meta
+ && $super_specific_meta->isa($specific_meta);
+}
+
sub _fix_class_metaclass_incompatibility {
my $self = shift;
my ( $super_meta ) = @_;
}
}
+sub _restore_metaobjects_from {
+ my $self = shift;
+ my ($old_meta) = @_;
+
+ for my $method ($old_meta->_get_local_methods) {
+ $self->_make_metaobject_compatible($method);
+ $self->add_method($method->name => $method);
+ }
+
+ for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
+ map { $old_meta->get_attribute($_) }
+ $old_meta->get_attribute_list) {
+ $self->_make_metaobject_compatible($attr);
+ $self->add_attribute($attr);
+ }
+}
+
+sub _remove_generated_metaobjects {
+ my $self = shift;
+
+ for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
+ $attr->remove_accessors;
+ }
+}
+
+sub _make_metaobject_compatible {
+ my $self = shift;
+ my ($object) = @_;
+
+ my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object));
+
+ if (!defined($new_metaclass)) {
+ confess "Can't make $object compatible with metaclass "
+ . $self->_get_associated_single_metaclass(blessed($object));
+ }
+
+ # can't use rebless_instance here, because it might not be an actual
+ # subclass in the case of, e.g. moose role reconciliation
+ $new_metaclass->meta->_force_rebless_instance($object)
+ if blessed($object) ne $new_metaclass;
+
+ return $object;
+}
+
+sub _get_associated_single_metaclass {
+ my $self = shift;
+ my ($single_meta_name) = @_;
+
+ my $current_single_meta_name;
+ if ($single_meta_name->isa('Class::MOP::Method')) {
+ $current_single_meta_name = $self->method_metaclass;
+ }
+ elsif ($single_meta_name->isa('Class::MOP::Attribute')) {
+ $current_single_meta_name = $self->attribute_metaclass;
+ }
+ else {
+ confess "Can't make $single_meta_name compatible, it isn't an "
+ . "attribute or method metaclass.";
+ }
+
+ return $current_single_meta_name;
+}
+
+sub _get_compatible_single_metaclass {
+ my $self = shift;
+ my ($single_meta_name) = @_;
+
+ return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name);
+}
+
+sub _get_compatible_single_metaclass_by_subclassing {
+ my $self = shift;
+ my ($single_meta_name) = @_;
+
+ my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
+
+ if ($single_meta_name->isa($current_single_meta_name)) {
+ return $single_meta_name;
+ }
+ elsif ($current_single_meta_name->isa($single_meta_name)) {
+ return $current_single_meta_name;
+ }
+
+ return;
+}
+
## ANON classes
{
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 clone_object {
my $class = shift;
my $instance = shift;
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;
# rebless!
# we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
$meta_instance->rebless_instance_structure($_[1], $self);
- 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));
- }
- }
- }
+ $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
+}
- foreach my $attr ($self->get_all_attributes) {
- $attr->initialize_instance_slot($meta_instance, $instance, \%params);
- }
-
- $instance;
+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
. $self->name
. ") isn't.";
- $old_metaclass->rebless_instance_away( $instance, $self )
- if $old_metaclass;
+ $self->_force_rebless_instance($_[1]);
- my $meta_instance = $self->get_meta_instance;
+ return $instance;
+}
- # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
- $meta_instance->rebless_instance_structure( $_[1], $self );
+sub rebless_instance_away {
+ # this intentionally does nothing, it is just a hook
+}
- for my $attr ( $old_metaclass->get_all_attributes ) {
- next if $self->has_attribute( $attr->name );
+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;
}
- return $instance;
-}
+ 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));
+ }
+ }
+ }
-sub rebless_instance_away {
- # this intentionally does nothing, it is just a hook
+ foreach my $attr ($self->get_all_attributes) {
+ $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+ }
}
sub _attach_attribute {
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
projects / gitmo/Class-MOP.git / blobdiff