From: gfx <gfuji@cpan.org>
Date: Fri, 5 Feb 2010 11:45:12 +0000 (+0900)
Subject: Catch up to Moose 0.94 metaroles
X-Git-Tag: 0.50~10
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=733f404b1631c344ec33fc9b23a90558cf06d781

Catch up to Moose 0.94 metaroles
---

diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 10dc14e..dba5c8c 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -81,8 +81,8 @@ sub superclasses {
 sub _reconcile_with_superclass_meta {
     my($self, $super_meta) = @_;
 
+    # find incompatible traits
     my @incompatibles;
-
     foreach my $metaclass_type(@MetaClassTypes){
         my $super_c = $super_meta->$metaclass_type();
         my $self_c  = $self->$metaclass_type();
@@ -93,9 +93,8 @@ sub _reconcile_with_superclass_meta {
     }
 
     my @roles;
-
-    foreach my $role($self->meta->calculate_all_roles){
-        if(!$super_meta->meta->does_role($role->name)){
+    foreach my $role($super_meta->meta->calculate_all_roles){
+        if(!$self->meta->does_role($role->name)){
             push @roles, $role->name;
         }
     }
diff --git a/lib/Mouse/Util/MetaRole.pm b/lib/Mouse/Util/MetaRole.pm
index 61e5fcd..21dc594 100644
--- a/lib/Mouse/Util/MetaRole.pm
+++ b/lib/Mouse/Util/MetaRole.pm
@@ -1,45 +1,106 @@
 package Mouse::Util::MetaRole;
 use Mouse::Util; # enables strict and warnings
+use Scalar::Util ();
 
-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 %args = @_;
+    _fixup_old_style_args(\%args);
+
+    return apply_metaroles(%args);
+}
+
+sub apply_metaroles {
+    my %args = @_;
+
+    my $for = Scalar::Util::blessed($args{for})
+        ?                                     $args{for}
+        : Mouse::Util::get_metaclass_by_name( $args{for} );
+
+    if ( Mouse::Util::is_a_metarole($for) ) {
+        return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
+    }
+    else {
+        return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
+    }
+}
+
+sub _make_new_metaclass {
+    my($for, $roles, $primary) = @_;
+
+    return $for unless keys %{$roles};
+
+    my $new_metaclass = exists($roles->{$primary})
+        ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
+        :                  ref $for;
+
+    my %classes;
+
+    for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
+        my $metaclass;
+        my $attr = $for->can($metaclass = ($key . '_metaclass'))
+                || $for->can($metaclass = ($key . '_class'))
+                || $for->throw_error("Unknown metaclass '$key'");
 
-    my $for = Scalar::Util::blessed($options{for_class})
-        ? $options{for_class}
-        : Mouse::Util::get_metaclass_by_name($options{for_class});
+        $classes{ $metaclass }
+            = _make_new_class( $for->$attr(), $roles->{$key} );
+    }
+
+    return $new_metaclass->reinitialize( $for, %classes );
+}
+
+
+sub _fixup_old_style_args {
+    my $args = shift;
+
+    return if $args->{class_metaroles} || $args->{roles_metaroles};
+
+    $args->{for} = delete $args->{for_class}
+        if exists $args->{for_class};
+
+    my @old_keys = qw(
+        attribute_metaclass_roles
+        method_metaclass_roles
+        wrapped_method_metaclass_roles
+        instance_metaclass_roles
+        constructor_class_roles
+        destructor_class_roles
+        error_class_roles
 
-    my $new_metaclass = _make_new_class( ref $for,
-        $options{metaclass_roles},
-        $options{metaclass} ? [$options{metaclass}] : undef,
+        application_to_class_class_roles
+        application_to_role_class_roles
+        application_to_instance_class_roles
+        application_role_summation_class_roles
     );
 
-    my @metaclass_map;
+    my $for = Scalar::Util::blessed($args->{for})
+        ?                                     $args->{for}
+        : Mouse::Util::get_metaclass_by_name( $args->{for} );
 
-    foreach my $mc_type(@MetaClassTypes){
-        next if !$for->can($mc_type);
+    my $top_key;
+    if( Mouse::Util::is_a_metaclass($for) ){
+        $top_key = 'class_metaroles';
 
-        if(my $roles = $options{ $mc_type . '_roles' }){
-            push @metaclass_map,
-                ($mc_type => _make_new_class($for->$mc_type(), $roles));
-        }
-        elsif(my $mc = $options{$mc_type}){
-            push @metaclass_map, ($mc_type => $mc);
-        }
+        $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
+            if exists $args->{metaclass_roles};
     }
+    else {
+        $top_key = 'role_metaroles';
 
-    return $new_metaclass->reinitialize( $for, @metaclass_map );
+        $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
+            if exists $args->{metaclass_roles};
+    }
+
+    for my $old_key (@old_keys) {
+        my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
+
+        $args->{$top_key}{$new_key} = delete $args->{$old_key}
+            if exists $args->{$old_key};
+    }
+
+    return;
 }
 
+
 sub apply_base_class_roles {
     my %options = @_;