From: Stevan Little <stevan.little@iinteractive.com>
Date: Wed, 12 Mar 2008 21:01:31 +0000 (+0000)
Subject: addin in the extra params for rebless_instance
X-Git-Tag: 0_64~82
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=214e4bd762a6153730b2556614d9e743b3180129;p=gitmo%2FClass-MOP.git

addin in the extra params for rebless_instance
---

diff --git a/Changes b/Changes
index d16baca..9bd31bf 100644
--- a/Changes
+++ b/Changes
@@ -2,7 +2,7 @@ Revision history for Perl extension Class-MOP.
 
 0.54
     * Class::MOP
-      metaclass
+      metaclass.pm
       - making sure that load_class never gets
         passed a value from @_ or $_ to squash 
         Ovid's bug (http://use.perl.org/~Ovid/journal/35763)
@@ -11,6 +11,9 @@ Revision history for Perl extension Class-MOP.
       - make_{immutable,mutable} now return 1
         (cause Sartak asked)
       - improved error handling in ->create method
+      - rebless_instance now takes extra params which 
+        will be used to populate values 
+        - added tests for this
         
     * Class::MOP::Object
       - localizing the Data::Dumper configurations so 
diff --git a/MANIFEST b/MANIFEST
index 59b8deb..2b8b135 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -69,6 +69,7 @@ t/043_instance_metaclass_incompat.t
 t/044_instance_metaclass_incompat_dyn.t
 t/045_metaclass_loads_classes.t
 t/046_rebless_instance.t
+t/047_rebless_with_extra_params.t
 t/050_scala_style_mixin_composition.t
 t/060_instance.t
 t/061_instance_inline.t
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index d5384f6..126f788 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -404,7 +404,7 @@ sub clone_instance {
 }
 
 sub rebless_instance {
-    my ($self, $instance) = @_;
+    my ($self, $instance, %params) = @_;
 
     my $old_metaclass;
     if ($instance->can('meta')) {
@@ -424,13 +424,13 @@ sub rebless_instance {
     # rebless!
     $meta_instance->rebless_instance_structure($instance, $self);
 
-    my %params;
-
     foreach my $attr ( $self->compute_all_applicable_attributes ) {
         if ( $attr->has_value($instance) ) {
             if ( defined( my $init_arg = $attr->init_arg ) ) {
-                $params{$init_arg} = $attr->get_value($instance);
-            } else {
+                $params{$init_arg} = $attr->get_value($instance)
+                    unless exists $params{$init_arg};
+            } 
+            else {
                 $attr->set_value($instance);
             }
         }
@@ -1137,11 +1137,12 @@ shallow cloning is outside the scope of the meta-object protocol. I
 think Yuval "nothingmuch" Kogman put it best when he said that cloning
 is too I<context-specific> to be part of the MOP.
 
-=item B<rebless_instance($instance)>
+=item B<rebless_instance($instance, ?%params)>
 
 This will change the class of C<$instance> to the class of the invoking
 C<Class::MOP::Class>. You may only rebless the instance to a subclass of
-itself. 
+itself. You may pass in optional C<%params> which are like constructor 
+params and will override anything already defined in the instance.
 
 =back
 
diff --git a/t/047_rebless_with_extra_params.t b/t/047_rebless_with_extra_params.t
new file mode 100644
index 0000000..a7842d4
--- /dev/null
+++ b/t/047_rebless_with_extra_params.t
@@ -0,0 +1,77 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 22;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Class::MOP');
+}
+
+{
+    package Foo;
+    use metaclass;
+    Foo->meta->add_attribute('bar' => (reader => 'bar'));
+    
+    sub new { (shift)->meta->new_object(@_) }
+    
+    package Bar;
+    use metaclass;
+    use base 'Foo';
+    Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ'));    
+}
+
+# normal ...
+{
+    my $foo = Foo->new(bar => 'BAR');
+    isa_ok($foo, 'Foo');
+
+    is($foo->bar, 'BAR', '... got the expect value');
+    ok(!$foo->can('baz'), '... no baz method though');
+
+    lives_ok {
+        Bar->meta->rebless_instance($foo)
+    } '... this works';
+
+    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');
+}
+
+# with extra params ...
+{
+    my $foo = Foo->new(bar => 'BAR');
+    isa_ok($foo, 'Foo');
+
+    is($foo->bar, 'BAR', '... got the expect value');
+    ok(!$foo->can('baz'), '... no baz method though');
+
+    lives_ok {
+        Bar->meta->rebless_instance($foo, (baz => 'FOO-BAZ'))
+    } '... this works';
+
+    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');
+}
+
+# with extra params ...
+{
+    my $foo = Foo->new(bar => 'BAR');
+    isa_ok($foo, 'Foo');
+
+    is($foo->bar, 'BAR', '... got the expect value');
+    ok(!$foo->can('baz'), '... no baz method though');
+
+    lives_ok {
+        Bar->meta->rebless_instance($foo, (bar => 'FOO-BAR', baz => 'FOO-BAZ'))
+    } '... this works';
+
+    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');
+}
+
+