From: Graham Knop <haarg@haarg.org>
Date: Wed, 1 Nov 2017 16:26:30 +0000 (+0100)
Subject: fix handling of does and DOES
X-Git-Tag: v1.000009~4
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FSafe-Isa.git;a=commitdiff_plain;h=9d3d6b490907e28992f225d4527a0460acb3c1d2

fix handling of does and DOES

does has no defined meaning in core. It is a convention established by
Moose-like modules.  In Moose/Moo/Mouse, does checks for roles only, not
parent classes.  $_does should not try to fall back to calling isa.

$_call_if_object shouldn't have any special handling for does or DOES,
it should just do exactly what it was asked to.  But it especially
shouldn't have special handling for things like 'Does'.

Because of these requirements, the implementations of does and DOES have
to be separate from what isa and can do.
---

diff --git a/lib/Safe/Isa.pm b/lib/Safe/Isa.pm
index e6457cf..fb3c5ab 100644
--- a/lib/Safe/Isa.pm
+++ b/lib/Safe/Isa.pm
@@ -15,14 +15,13 @@ our $_call_if_object = sub {
   # we gratuitously break modules like Scalar::Defer, which would be
   # un-perlish.
   return unless Scalar::Util::blessed($obj);
-  return $obj->isa(@_) if lc($method) eq 'does' and not $obj->can($method);
   return $obj->$method(@_);
 };
 
-our ($_isa, $_can, $_does, $_DOES) = map {
+our ($_isa, $_can) = map {
   my $method = $_;
   sub { my $obj = shift; $obj->$_call_if_object($method => @_) }
-} qw(isa can does DOES);
+} qw(isa can);
 
 our $_call_if_can = sub {
   my ($obj, $method) = (shift, shift);
@@ -30,6 +29,19 @@ our $_call_if_can = sub {
   return $obj->$method(@_);
 };
 
+our $_does = sub {
+  my $obj = shift;
+  $obj->$_call_if_can(does => @_);
+};
+
+our $_DOES = sub {
+  my $obj = shift;
+  return unless Scalar::Util::blessed($obj);
+  return $obj->DOES(@_)
+    if $obj->can('DOES');
+  return $obj->isa(@_);
+};
+
 1;
 __END__
 
diff --git a/t/safe_does.t b/t/safe_does.t
index a3a21cf..e1ae548 100644
--- a/t/safe_does.t
+++ b/t/safe_does.t
@@ -1,6 +1,6 @@
 use strict;
 use warnings;
-use Test::More tests => 14;
+use Test::More tests => 20;
 
 { package Foo; sub new { bless({}, $_[0]) } }
 { package Bar; our @ISA = qw(Foo); sub bar { 1 } sub does { $_[0]->isa($_[1]) } }
@@ -36,9 +36,16 @@ ok($bar->$_DOES('Foo'), 'bar $_DOES Foo');
 ok(eval { $blam->$_DOES('Foo'); 1 }, 'no boom today');
 ok(eval { $undef->$_DOES('Foo'); 1 }, 'nor tomorrow either');
 
+# does should not fall back to isa
+ok(!$foo->$_does('Foo'), 'foo !$_does Foo');
+ok($bar->$_does('Foo'), 'bar $_does Foo');
+ok(eval { $blam->$_does('Foo'); 1 }, 'no boom today');
+ok(eval { $undef->$_does('Foo'); 1 }, 'nor tomorrow either');
 
 ok($foo->$_call_if_object(DOES => 'Foo'), 'foo $_call_if_object(DOES => Foo)');
 ok($bar->$_call_if_object(DOES => 'Foo'), 'bar $_call_if_object(DOES => Foo)');
 ok(eval { $blam->$_call_if_object(DOES => 'Foo'); 1 }, 'no boom today');
 ok(eval { $undef->$_call_if_object(DOES => 'Foo'); 1 }, 'nor tomorrow either');
 
+ok(!eval { $foo->$_call_if_object(does => 'Foo'); 1 }, 'no special DOES handling built into _call_if_object');
+ok(!eval { $foo->$_call_if_object(Does => 'Foo'); 1 }, 'and no handling for wrong case');