From: gfx <gfuji@cpan.org>
Date: Thu, 26 Nov 2009 12:15:43 +0000 (+0900)
Subject: Fix metaclass compatibility resolution
X-Git-Tag: 0.40_08~9
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9659f80a6e4f20234968fcc003570c0da6b6ff1;p=gitmo%2FMouse.git

Fix metaclass compatibility resolution
---

diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 0cc4b71..47fd266 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -6,12 +6,19 @@ use Scalar::Util qw/blessed weaken/;
 use Mouse::Meta::Module;
 our @ISA = qw(Mouse::Meta::Module);
 
-sub method_metaclass;
 sub attribute_metaclass;
+sub method_metaclass;
 
 sub constructor_class;
 sub destructor_class;
 
+my @MetaClassTypes = qw(
+    attribute_metaclass
+    method_metaclass
+    constructor_class
+    destructor_class
+);
+
 sub _construct_meta {
     my($class, %args) = @_;
 
@@ -71,13 +78,6 @@ sub superclasses {
     return @{ $self->{superclasses} };
 }
 
-my @MetaClassTypes = qw(
-    attribute_metaclass
-    method_metaclass
-    constructor_class
-    destructor_class
-);
-
 sub _reconcile_with_superclass_meta {
     my($self, $super_meta) = @_;
 
@@ -92,11 +92,26 @@ sub _reconcile_with_superclass_meta {
         }
     }
 
-    $super_meta->reinitialize($self, @incompatibles);
+    my @roles;
+
+    foreach my $role($self->meta->calculate_all_roles){
+        if(!$super_meta->meta->does_role($role->name)){
+            push @roles, $role->name;
+        }
+    }
+
+    #print "reconcile($self vs. $super_meta; @roles; @incompatibles)\n";
+
+    require Mouse::Util::MetaRole;
+    Mouse::Util::MetaRole::apply_metaclass_roles(
+        for_class       => $self,
+        metaclass       => ref $super_meta,
+        metaclass_roles => \@roles,
+        @incompatibles,
+    );
     return;
 }
 
-
 sub find_method_by_name{
     my($self, $method_name) = @_;
     defined($method_name)
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index a226e1e..eb0463f 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -52,6 +52,9 @@ BEGIN{
         $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
             require XSLoader;
             XSLoader::load('Mouse', $VERSION);
+
+            *Mouse::Meta::Method::Constructor::XS::meta = \&meta;
+            *Mouse::Meta::Method::Destructor::XS::meta  = \&meta;
         };
         #warn $@ if $@;
     }
diff --git a/lib/Mouse/Util/MetaRole.pm b/lib/Mouse/Util/MetaRole.pm
index fe68cbe..668b35c 100644
--- a/lib/Mouse/Util/MetaRole.pm
+++ b/lib/Mouse/Util/MetaRole.pm
@@ -1,35 +1,43 @@
 package Mouse::Util::MetaRole;
 use Mouse::Util; # enables strict and warnings
 
-our @Classes = qw(constructor_class destructor_class);
+my @MetaClassTypes = qw(
+    metaclass
+    attribute_metaclass
+    method_metaclass
+    constructor_class
+    destructor_class
+);
 
+# In Mouse::Exporter::do_import():
+# apply_metaclass_roles(for_class => $class, metaclass_roles => \@traits)
 sub apply_metaclass_roles {
     my %options = @_;
 
     my $for = Scalar::Util::blessed($options{for_class})
         ? $options{for_class}
-        : Mouse::Util::class_of($options{for_class});
+        : Mouse::Util::get_metaclass_by_name($options{for_class});
 
-    my %old_classes = map { $for->can($_) ? ($_ => $for->$_) : () }
-                      @Classes;
+    my $new_metaclass = _make_new_class( ref $for,
+        $options{metaclass_roles},
+        $options{metaclass} ? [$options{metaclass}] : undef,
+    );
 
-    my $meta = _make_new_metaclass( $for, \%options );
+    my @metaclass_map;
 
-    for my $c ( grep { $meta->can($_) } @Classes ) {
-        if ( $options{ $c . '_roles' } ) {
-            my $class = _make_new_class(
-                $meta->$c(),
-                $options{ $c . '_roles' }
-            );
+    foreach my $mc_type(@MetaClassTypes){
+        next if !$for->can($mc_type);
 
-            $meta->$c($class);
+        if(my $roles = $options{ $mc_type . '_roles' }){
+            push @metaclass_map,
+                ($mc_type => _make_new_class($for->$mc_type(), $roles));
         }
-        elsif($meta->$c ne $old_classes{$c}){
-            $meta->$c( $old_classes{$c} );
+        elsif(my $mc = $options{$mc_type}){
+            push @metaclass_map, ($mc_type => $mc);
         }
     }
 
-    return $meta;
+    return $new_metaclass->reinitialize( $for, @metaclass_map );
 }
 
 sub apply_base_class_roles {
@@ -50,40 +58,17 @@ sub apply_base_class_roles {
     return;
 }
 
-
-my @Metaclasses = qw(
-    metaclass
-    attribute_metaclass
-    method_metaclass
-);
-
-sub _make_new_metaclass {
-    my($for, $options) = @_;
-
-    return $for
-        if !grep { exists $options->{ $_ . '_roles' } } @Metaclasses;
-
-    my $new_metaclass
-        = _make_new_class( ref $for, $options->{metaclass_roles} );
-
-    # This could get called for a Mouse::Meta::Role as well as a Mouse::Meta::Class
-    my %classes = map {
-        $_ => _make_new_class( $for->$_(), $options->{ $_ . '_roles' } )
-    }  grep { $for->can($_) } @Metaclasses;
-
-    return $new_metaclass->reinitialize( $for, %classes );
-}
-
-
 sub _make_new_class {
     my($existing_class, $roles, $superclasses) = @_;
 
-    return $existing_class if !$roles;
+    if(!$superclasses){
+        return $existing_class if !$roles;
 
-    my $meta = Mouse::Meta::Class->initialize($existing_class);
+        my $meta = Mouse::Meta::Class->initialize($existing_class);
 
-    return $existing_class
-        if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
+        return $existing_class
+            if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
+    }
 
     return Mouse::Meta::Class->create_anon_class(
         superclasses => $superclasses ? $superclasses : [$existing_class],