Adjusted default 'isa' typeconstraint construction to check if the

specified type name is a known role, and constrain with 'does' instead
of 'isa' if it is.  This brings Mouse in line with how Moose behaves
for this case.  Testcase added to t/025-more-isa.t.

diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index 6a9ee57..3ed075d 100644 (file)
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -282,10 +282,14 @@ sub _build_type_constraint {
     } else {
         $code = $TYPE{ $spec };
         if (! $code) {
+            # is $spec a known role?  If so, constrain with 'does' instead of 'isa'
+            require Mouse::Meta::Role;
+            my $check = Mouse::Meta::Role->_metaclass_cache($spec)? 
+                'does' : 'isa';
             my $code_str = 
                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
                 "sub {\n" .
-                "    Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" .
+                "    Scalar::Util::blessed(\$_[0]) && \$_[0]->$check('$spec');\n" .
                 "}"
             ;
             $code = eval $code_str  or Carp::confess($@);

diff --git a/t/025-more-isa.t b/t/025-more-isa.t
old mode 100644 (file)
new mode 100755 (executable)
index 0be7603..576d5e1
--- a/t/025-more-isa.t
+++ b/t/025-more-isa.t
@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use Test::More tests => 30;
+use Test::More tests => 34;
 use Test::Exception;
 
 do {
@@ -138,3 +138,37 @@ for ('F', 'G', 'I', 'Z') {
     } qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value $_/;
 };
 
+
+# Check that Roles can be used in 'isa' and they are constrained with
+# 'does'
+do {
+    package SausageRole;
+    use Mouse::Role;
+
+    package DoesSausage;
+    use Mouse;
+    with 'SausageRole';
+
+    package HasSausage;
+    use Mouse;
+
+    has sausage =>
+        (isa => 'SausageRole',
+         is => 'rw');
+
+};
+
+my $hs;
+lives_ok {
+    $hs = HasSausage->new(sausage => DoesSausage->new);    
+};
+lives_ok {
+    $hs->sausage(DoesSausage->new);
+};
+throws_ok {
+    HasSausage->new(sausage => Class->new);   
+} qr/^Attribute \(sausage\) does not pass the type constraint because: Validation failed for 'SausageRole' failed with value Class=/;
+throws_ok {
+    $hs->sausage(Class->new);   
+} qr/^Attribute \(sausage\) does not pass the type constraint because: Validation failed for 'SausageRole' failed with value Class=/;
+