From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 7 May 2012 18:47:30 +0000 (+0000)
Subject: inhale Mouse
X-Git-Tag: v0.091004~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c100c04c5cb277dec823a91c3d64e1ed36537981;p=gitmo%2FMoo.git

inhale Mouse
---

diff --git a/Changes b/Changes
index 8e4ca17..1092bea 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,4 @@
+  - also inhale from Mouse
   - clarify how isa and coerce interact
   - support isa and coerce together for Moose
   - guard _accessor_maker_for calls in Moo::Role in case Moo isn't loaded
diff --git a/lib/Moo.pm b/lib/Moo.pm
index 90469ab..cd65690 100644
--- a/lib/Moo.pm
+++ b/lib/Moo.pm
@@ -26,6 +26,9 @@ sub import {
       Moo->_constructor_maker_for($target)
          ->register_attribute_specs(%{$old->all_attribute_specs});
     }
+    $Moo::HandleMoose::MOUSE{$target} = [
+      grep defined, map Mouse::Util::find_meta($_), @_
+    ] if $INC{"Mouse.pm"};
     $class->_maybe_reset_handlemoose($target);
   };
   _install_coderef "${target}::with" => "Moo::with" => sub {
@@ -231,8 +234,13 @@ L<Moose> everywhere.
 
 Extending a L<Moose> class or consuming a L<Moose::Role> should also work.
 
+So should extending a L<Mouse> class or consuming a L<Mouse::Role>.
+
 This means that there is no need for anything like L<Any::Moose> for Moo
-code - Moo and Moose code should simply interoperate without problem.
+code - Moo and Moose code should simply interoperate without problem. To
+handle L<Mouse> code, you'll likely need an empty Moo role or class consuming
+or extending the L<Mouse> stuff since it doesn't register true L<Moose>
+metaclasses like we do.
 
 However, these features are new as of 0.91.0 (0.091000) so while serviceable,
 they are absolutely certain to not be 100% yet; please do report bugs.
diff --git a/lib/Moo/HandleMoose.pm b/lib/Moo/HandleMoose.pm
index f1d9c89..99dbf45 100644
--- a/lib/Moo/HandleMoose.pm
+++ b/lib/Moo/HandleMoose.pm
@@ -62,6 +62,7 @@ sub inject_real_metaclass_for {
       );
     }
   };
+    
   my %methods = %{Role::Tiny->_concrete_methods_of($name)};
   # needed to ensure the method body is stable and get things named
   Sub::Defer::undefer_sub($_) for grep defined, values %methods;
@@ -69,7 +70,9 @@ sub inject_real_metaclass_for {
   {
     # This local is completely not required for roles but harmless
     local @{_getstash($name)}{keys %methods};
+    my %seen_name;
     foreach my $name (@$attr_order) {
+      $seen_name{$name} = 1;
       my %spec = %{$attr_specs->{$name}};
       delete $spec{index};
       $spec{is} = 'ro' if $spec{is} eq 'lazy' or $spec{is} eq 'rwp';
@@ -104,6 +107,18 @@ sub inject_real_metaclass_for {
       }
       push @attrs, $meta->add_attribute($name => %spec);
     }
+    foreach my $mouse (do { our %MOUSE; @{$MOUSE{$name}||[]} }) {
+      foreach my $attr ($mouse->get_all_attributes) {
+        my %spec = %{$attr};
+        delete @spec{qw(
+          associated_class associated_methods __METACLASS__
+          provides curries
+        )};
+        my $name = delete $spec{name};
+        next if $seen_name{$name}++;
+        push @attrs, $meta->add_attribute($name => %spec);
+      }
+    }
   }
   if ($am_role) {
     my $info = $Moo::Role::INFO{$name};
diff --git a/lib/Moo/Role.pm b/lib/Moo/Role.pm
index 4227034..5145edc 100644
--- a/lib/Moo/Role.pm
+++ b/lib/Moo/Role.pm
@@ -66,32 +66,45 @@ sub _maybe_reset_handlemoose {
 sub _inhale_if_moose {
   my ($self, $role) = @_;
   _load_module($role);
-  if (!$INFO{$role} and $INC{"Moose.pm"}) {
-    if (my $meta = Class::MOP::class_of($role)) {
-      $INFO{$role}{methods} = {
-        map +($_ => $role->can($_)),
-          grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'),
-            $meta->get_method_list
-      };
-      $Role::Tiny::APPLIED_TO{$role} = {
-        map +($_->name => 1), $meta->calculate_all_roles
-      };
-      $INFO{$role}{requires} = [ $meta->get_required_method_list ];
-      $INFO{$role}{attributes} = [
-        map +($_ => $meta->get_attribute($_)), $meta->get_attribute_list
-      ];
-      my $mods = $INFO{$role}{modifiers} = [];
-      foreach my $type (qw(before after around)) {
-        my $map = $meta->${\"get_${type}_method_modifiers_map"};
-        foreach my $method (keys %$map) {
-          foreach my $mod (@{$map->{$method}}) {
-            push @$mods, [ $type => $method => $mod ];
-          }
+  my $meta;
+  if (!$INFO{$role}
+      and (
+        $INC{"Moose.pm"}
+        and $meta = Class::MOP::class_of($role)
+      )
+      or (
+        $INC{"Mouse.pm"}
+        and $meta = Mouse::Util::find_meta($role)
+     )
+  ) {
+    $INFO{$role}{methods} = {
+      map +($_ => $role->can($_)),
+        grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'),
+          $meta->get_method_list
+    };
+    $Role::Tiny::APPLIED_TO{$role} = {
+      map +($_->name => 1), $meta->calculate_all_roles
+    };
+    $INFO{$role}{requires} = [ $meta->get_required_method_list ];
+    $INFO{$role}{attributes} = [
+      map +($_ => $meta->get_attribute($_)), $meta->get_attribute_list
+    ];
+    my $mods = $INFO{$role}{modifiers} = [];
+    foreach my $type (qw(before after around)) {
+      # Mouse pokes its own internals so we have to fall back to doing
+      # the same thing in the absence of the Moose API method
+      my $map = $meta->${\(
+        $meta->can("get_${type}_method_modifiers_map")
+        or sub { shift->{"${type}_method_modifiers"} }
+      )};
+      foreach my $method (keys %$map) {
+        foreach my $mod (@{$map->{$method}}) {
+          push @$mods, [ $type => $method => $mod ];
         }
       }
-      require Class::Method::Modifiers if @$mods;
-      $INFO{$role}{inhaled_from_moose} = 1;
     }
+    require Class::Method::Modifiers if @$mods;
+    $INFO{$role}{inhaled_from_moose} = 1;
   }
 }
 
diff --git a/xt/moo-does-moose-role.t b/xt/moo-does-moose-role.t
index 6db3919..9f5c25d 100644
--- a/xt/moo-does-moose-role.t
+++ b/xt/moo-does-moose-role.t
@@ -18,6 +18,22 @@ BEGIN {
 }
 
 BEGIN {
+  package Splat2;
+
+  use Mouse::Role;
+
+  requires 'monkey';
+
+  sub punch { 1 }
+
+  sub jab { 0 }
+
+  around monkey => sub { 'OW' };
+
+  has trap => (is => 'ro', default => sub { -1 });
+}
+
+BEGIN {
   package Splattered;
 
   use Moo;
@@ -29,11 +45,23 @@ BEGIN {
   sub jab { 3 }
 }
 
-my $s = Splattered->new;
+BEGIN {
+  package Splattered2;
+
+  use Moo;
+
+  sub monkey { 'WHAT' }
+
+  with 'Splat2';
+
+  sub jab { 3 }
+}
 
-is($s->punch, 1, 'punch');
-is($s->jab, 3, 'jab');
-is($s->monkey, 'OW', 'monkey');
-is($s->trap, -1, 'trap');
+foreach my $s (Splattered->new, Splattered2->new) {
+  is($s->punch, 1, 'punch');
+  is($s->jab, 3, 'jab');
+  is($s->monkey, 'OW', 'monkey');
+  is($s->trap, -1, 'trap');
+}
 
 done_testing;
diff --git a/xt/super-jenga.t b/xt/super-jenga.t
new file mode 100644
index 0000000..d67dee2
--- /dev/null
+++ b/xt/super-jenga.t
@@ -0,0 +1,38 @@
+use strictures 1;
+use Test::More;
+
+{
+  package Tower1;
+
+  use Mouse;
+
+  has 'attr1' => (is => 'ro', required => 1);
+
+  package Tower2;
+
+  use Moo;
+
+  extends 'Tower1';
+
+  has 'attr2' => (is => 'ro', required => 1);
+
+  package Tower3;
+
+  use Moose;
+
+  extends 'Tower2';
+
+  has 'attr3' => (is => 'ro', required => 1);
+
+  __PACKAGE__->meta->make_immutable;
+}
+
+foreach my $num (1..3) {
+  my $class = "Tower${num}";
+  my @attrs = map "attr$_", 1..$num;
+  my %args = map +($_ => "${_}_value"), @attrs;
+  my $obj = $class->new(%args);
+  is($obj->{$_}, "${_}_value", "Attribute $_ ok for $class") for @attrs;
+}
+
+done_testing;