From: Karen Etheridge <ether@cpan.org>
Date: Sun, 15 Mar 2015 01:09:20 +0000 (-0700)
Subject: Make ->does, ->DOES safe on old perls (RT#100866)
X-Git-Tag: v1.000006~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de8d80ef665baf5e89e0574604fd63e091f73723;p=p5sagit%2FSafe-Isa.git

Make ->does, ->DOES safe on old perls (RT#100866)
---

diff --git a/Changes b/Changes
index 6cde6ba..382aca7 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for Safe-Isa
 
+  - now falling back to $obj->isa if DOES/does is not implemented on the
+    object, to avoid fatal errors on perls too old to have their own DOES
+    (RT#100866)
+
 1.000005 - 2014-08-16
   - comment blessed use so people who don't know perl stop trying to break it
   - add link to lightning talk given at YAPC::NA 2013
diff --git a/lib/Safe/Isa.pm b/lib/Safe/Isa.pm
index 47cfd3e..bdd93e5 100644
--- a/lib/Safe/Isa.pm
+++ b/lib/Safe/Isa.pm
@@ -15,6 +15,7 @@ our $_call_if_object = sub {
   # we gratuitously break modules like Scalar::Defer, which would be
   # un-perlish.
   return unless blessed($obj);
+  return $obj->isa(@_) if lc($method) eq 'does' and not $obj->can($method);
   return $obj->$method(@_);
 };
 
diff --git a/t/safe_does.t b/t/safe_does.t
new file mode 100644
index 0000000..a3a21cf
--- /dev/null
+++ b/t/safe_does.t
@@ -0,0 +1,44 @@
+use strict;
+use warnings;
+use Test::More tests => 14;
+
+{ package Foo; sub new { bless({}, $_[0]) } }
+{ package Bar; our @ISA = qw(Foo); sub bar { 1 } sub does { $_[0]->isa($_[1]) } }
+
+my $foo = Foo->new;
+my $bar = Bar->new;
+my $blam = [ 42 ];
+my $undef;
+
+# basic does, DOES usage -
+# on perls >= 5.10.0, DOES falls back to isa.
+# does must always be manually provided
+
+if (UNIVERSAL->can('DOES')) {
+  ok($foo->DOES('Foo'), 'foo DOES Foo');
+  ok($bar->DOES('Foo'), 'bar DOES Foo');
+}
+else {
+  ok(!eval { $foo->DOES('Foo') }, 'DOES not available in UNIVERSAL');
+  ok(!eval { $bar->DOES('Foo') }, 'DOES not available in UNIVERSAL');
+}
+
+ok(!eval { $foo->does('Foo') }, 'does not implemented on Foo');
+ok($bar->does('Foo'), 'bar does Foo');
+ok(!eval { $blam->DOES('Foo'); 1 }, 'blam goes blam');
+ok(!eval { $undef->DOES('Foo'); 1 }, 'undef goes poof');
+
+
+use Safe::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');
+