From: Jesse Luehrs Date: Mon, 4 Jan 2010 20:21:39 +0000 (-0600) Subject: Merge topic/reinitialize_instance_back to master. X-Git-Tag: 0.98~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0708313d80515eebcc37dd2cfa6537ca3971c827;p=gitmo%2FClass-MOP.git Merge topic/reinitialize_instance_back to master. Adds a rebless_instance_back method to CMOP::Class, which allows you to rebless an object into a parent class. Squashed commit of the following: commit 163e33b72ad010907a64d39f7ade7ab257e6bf97 Author: Dave Rolsky Date: Mon Jan 4 14:18:35 2010 -0600 Add deinitialized to whitelist commit 7ae09debd63b91febc33c3395de34fb3635efdf9 Author: Dave Rolsky Date: Mon Jan 4 14:16:44 2010 -0600 Run new code through tidy commit 2586d8600533aa060741991a25ade044668cdbcd Author: Jesse Luehrs Date: Sat Dec 19 16:17:07 2009 -0600 implement rebless_instance_back --- diff --git a/Changes b/Changes index 26d680c..271f2cd 100644 --- a/Changes +++ b/Changes @@ -6,6 +6,10 @@ Revision history for Perl extension Class-MOP. classes. This made adding some new features to Moose much easier. (Dave Rolsky) + * Class::MOP::Class + - Added rebless_instance_back, which does the inverse of + rebless_instance (doy, rafl). + 0.97 Fri, Dec 18, 2009 * No code changes, just packaging fixes to make this distro installable. diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index d5e4f0f..f8f51de 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -465,6 +465,35 @@ sub rebless_instance { $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."; + + $old_metaclass->rebless_instance_away( $instance, $self ) + if $old_metaclass; + + my $meta_instance = $self->get_meta_instance; + + # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8 + $meta_instance->rebless_instance_structure( $_[1], $self ); + + for my $attr ( $old_metaclass->get_all_attributes ) { + next if $self->has_attribute( $attr->name ); + $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots; + } + + return $instance; +} + sub rebless_instance_away { # this intentionally does nothing, it is just a hook } @@ -1250,6 +1279,15 @@ will be passed the instance, the new metaclass, and any parameters specified to C. By default, C does nothing; it is merely a hook. +=item B<< $metaclass->rebless_instance_back($instance) >> + +Does the same thing as C, 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, +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 diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 2f0f17b..c81cb01 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -65,7 +65,7 @@ my @class_mop_class_methods = qw( construct_instance _construct_instance construct_class_instance _construct_class_instance clone_instance _clone_instance - rebless_instance rebless_instance_away + rebless_instance rebless_instance_back rebless_instance_away check_metaclass_compatibility _check_metaclass_compatibility add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies diff --git a/t/046_rebless_instance.t b/t/046_rebless_instance.t index f5e8b0e..7eb0f68 100644 --- a/t/046_rebless_instance.t +++ b/t/046_rebless_instance.t @@ -47,6 +47,18 @@ throws_ok { LeftField->meta->rebless_instance($foo) } throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) } qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./; +Parent->meta->rebless_instance_back($foo); +is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); +is($foo->whoami, "parent", 'Parent->whoami gives parent'); +is($foo->parent, "parent", 'Parent->parent gives parent'); +dies_ok { $foo->child } "Parent->child method doesn't exist"; + +throws_ok { LeftField->meta->rebless_instance_back($foo) } + qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./; + +throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) } + qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./; + # make sure our ->meta is still sane my $bar = Parent->new; is(blessed($bar), 'Parent', "sanity check"); @@ -73,4 +85,15 @@ ok($bar->meta->has_method('child'), 'metaclass has "child" method'); is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child'); +Parent->meta->rebless_instance_back($bar); +is(blessed($bar), 'Parent', "sanity check"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); + +ok($bar->meta->has_method('new'), 'metaclass has "new" method'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); + +is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); + done_testing; diff --git a/t/047_rebless_with_extra_params.t b/t/047_rebless_with_extra_params.t index 5196ebf..17af892 100644 --- a/t/047_rebless_with_extra_params.t +++ b/t/047_rebless_with_extra_params.t @@ -34,6 +34,12 @@ use Class::MOP; is($foo->bar, 'BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'BAZ', '... got the expect value'); + + lives_ok { + Foo->meta->rebless_instance_back($foo) + } '... this works'; + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); } # with extra params ... @@ -51,6 +57,14 @@ use Class::MOP; is($foo->bar, 'BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + lives_ok { + Foo->meta->rebless_instance_back($foo) + } '... this works'; + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); } # with extra params ... @@ -68,6 +82,14 @@ use Class::MOP; is($foo->bar, 'FOO-BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + lives_ok { + Foo->meta->rebless_instance_back($foo) + } '... this works'; + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); } done_testing; diff --git a/xt/author/pod_spell.t b/xt/author/pod_spell.t index f3f5b21..3431017 100644 --- a/xt/author/pod_spell.t +++ b/xt/author/pod_spell.t @@ -95,6 +95,7 @@ clearers continutation datetimes definedness +deinitialized destructor destructors DWIM