Mouse::Util::does_role() respects $thing->does() method

[gitmo/Mouse.git] / lib / Mouse / Util.pm

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index bd64d15..17d7efe 100644 (file)
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -1,6 +1,8 @@
 package Mouse::Util;
 use Mouse::Exporter; # enables strict and warnings
 
+# Note that those which don't exist here are defined in XS or Mouse::PurePerl
+
 # must be here because it will be refered by other modules loaded
 sub get_linear_isa($;$); ## no critic
 
@@ -48,7 +50,7 @@ BEGIN{
         },
     );
 
-    our $VERSION = '0.73';
+    our $VERSION = '0.95';
 
     my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});
 
@@ -75,6 +77,59 @@ BEGIN{
     }
 
     *MOUSE_XS = sub(){ $xs };
+
+    # definition of mro::get_linear_isa()
+    my $get_linear_isa;
+    if ($] >= 5.010_000) {
+        require mro;
+        $get_linear_isa = \&mro::get_linear_isa;
+    }
+    else {
+        # this code is based on MRO::Compat::__get_linear_isa
+        my $_get_linear_isa_dfs; # this recurses so it isn't pretty
+        $_get_linear_isa_dfs = sub {
+            my($classname) = @_;
+
+            my @lin = ($classname);
+            my %stored;
+
+            no strict 'refs';
+            foreach my $parent (@{"$classname\::ISA"}) {
+                foreach  my $p(@{ $_get_linear_isa_dfs->($parent) }) {
+                    next if exists $stored{$p};
+                    push(@lin, $p);
+                    $stored{$p} = 1;
+                }
+            }
+            return \@lin;
+        };
+
+        {
+            package # hide from PAUSE
+                Class::C3;
+            our %MRO; # avoid 'once' warnings
+        }
+
+        # MRO::Compat::__get_linear_isa has no prototype, so
+        # we define a prototyped version for compatibility with core's
+        # See also MRO::Compat::__get_linear_isa.
+        $get_linear_isa = sub ($;$){
+            my($classname, $type) = @_;
+
+            if(!defined $type){
+                $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
+            }
+            if($type eq 'c3'){
+                require Class::C3;
+                return [Class::C3::calculateMRO($classname)];
+            }
+            else{
+                return $_get_linear_isa_dfs->($classname);
+            }
+        };
+    }
+
+    *get_linear_isa = $get_linear_isa;
 }
 
 use Carp         ();
@@ -114,7 +169,7 @@ sub find_meta{
     return class_of( $_[0] );
 }
 
-sub does_role{
+sub _does_role_impl {
     my ($class_or_obj, $role_name) = @_;
 
     my $meta = class_of($class_or_obj);
@@ -125,60 +180,16 @@ sub does_role{
     return defined($meta) && $meta->does_role($role_name);
 }
 
-BEGIN {
-    my $get_linear_isa;
-    if ($] >= 5.009_005) {
-        require mro;
-        $get_linear_isa = \&mro::get_linear_isa;
-    } else {
-        # this code is based on MRO::Compat::__get_linear_isa
-        my $_get_linear_isa_dfs; # this recurses so it isn't pretty
-        $_get_linear_isa_dfs = sub {
-            my($classname) = @_;
-
-            my @lin = ($classname);
-            my %stored;
-
-            no strict 'refs';
-            foreach my $parent (@{"$classname\::ISA"}) {
-                foreach  my $p(@{ $_get_linear_isa_dfs->($parent) }) {
-                    next if exists $stored{$p};
-                    push(@lin, $p);
-                    $stored{$p} = 1;
-                }
-            }
-            return \@lin;
-        };
+sub does_role {
+    my($thing, $role_name) = @_;
 
-        {
-            package # hide from PAUSE
-                Class::C3;
-            our %MRO; # avoid 'once' warnings
-        }
-
-        # MRO::Compat::__get_linear_isa has no prototype, so
-        # we define a prototyped version for compatibility with core's
-        # See also MRO::Compat::__get_linear_isa.
-        $get_linear_isa = sub ($;$){
-            my($classname, $type) = @_;
-
-            if(!defined $type){
-                $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
-            }
-            if($type eq 'c3'){
-                require Class::C3;
-                return [Class::C3::calculateMRO($classname)];
-            }
-            else{
-                return $_get_linear_isa_dfs->($classname);
-            }
-        };
+    if( (Scalar::Util::blessed($thing) || is_class_loaded($thing))
+            && $thing->can('does')) {
+        return $thing->does($role_name);
     }
-
-    *get_linear_isa = $get_linear_isa;
+    goto &_does_role_impl;
 }
 
-
 # taken from Mouse::Util (0.90)
 {
     my %cache;
@@ -212,6 +223,7 @@ sub get_code_info;
 sub get_code_package;
 
 sub is_valid_class_name;
+sub is_class_loaded;
 
 # taken from Class/MOP.pm
 sub load_first_existing_class {
@@ -270,7 +282,6 @@ sub load_class {
     return $class;
 }
 
-sub is_class_loaded;
 
 sub apply_all_roles {
     my $consumer = Scalar::Util::blessed($_[0])
@@ -376,7 +387,7 @@ sub dump :method {
 
 # general does() method
 sub does :method {
-    goto &does_role;
+    goto &_does_role_impl;
 }
 
 1;
@@ -388,7 +399,7 @@ Mouse::Util - Utilities for working with Mouse classes
 
 =head1 VERSION
 
-This document describes Mouse version 0.73
+This document describes Mouse version 0.95
 
 =head1 SYNOPSIS
 
@@ -442,7 +453,7 @@ C<eval "use $module ()"> or using C<require>.
 
 =head3 C<< Mouse::Util::get_all_metaclass_names() -> (ClassNames) >>
 
-=head2 MRO::Compat
+=head2 mro (or MRO::Compat)
 
 =head3 C<get_linear_isa>
 
@@ -466,6 +477,8 @@ L<Class::MOP>
 
 L<Sub::Identify>
 
+L<mro>
+
 L<MRO::Compat>
 
 =cut