From: Karen Etheridge <ether@cpan.org>
Date: Fri, 22 Sep 2017 02:20:56 +0000 (-0700)
Subject: $_call_if_can
X-Git-Tag: v1.000007~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FSafe-Isa.git;a=commitdiff_plain;h=ff5366dba91627d0ce2cab3500db8ae094625a4f

$_call_if_can
---

diff --git a/Changes b/Changes
index 60d1e91..22c61e9 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Safe-Isa
 
+  - added new interface: $obj->$_call_if_can
+
 1.000006 - 2016-10-31
   - 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
diff --git a/lib/Safe/Isa.pm b/lib/Safe/Isa.pm
index 2f4f357..2e29b3c 100644
--- a/lib/Safe/Isa.pm
+++ b/lib/Safe/Isa.pm
@@ -7,7 +7,7 @@ use Exporter 5.57 qw(import);
 
 our $VERSION = '1.000006';
 
-our @EXPORT = qw($_call_if_object $_isa $_can $_does $_DOES);
+our @EXPORT = qw($_call_if_object $_isa $_can $_does $_DOES $_call_if_can);
 
 our $_call_if_object = sub {
   my ($obj, $method) = (shift, shift);
@@ -24,6 +24,11 @@ our ($_isa, $_can, $_does, $_DOES) = map {
   sub { my $obj = shift; $obj->$_call_if_object($method => @_) }
 } qw(isa can does DOES);
 
+our $_call_if_can = sub {
+  my ($obj, $method) = (shift, shift);
+  $obj->$_call_if_object(can => $method) && $obj->$_call_if_object($method => @_);
+};
+
 1;
 __END__
 
@@ -72,9 +77,10 @@ Similarly:
   $maybe_an_object->$_does('RoleName'); # true or false, no boom today
   $maybe_an_object->$_DOES('RoleName'); # true or false, no boom today
 
-And just in case we missed a method:
+And just in case we missed a method or two:
 
   $maybe_an_object->$_call_if_object(name => @args);
+  $maybe_an_object->$_call_if_can(name => @args);
 
 Or to re-use a previous example for purposes of explication:
 
@@ -154,6 +160,14 @@ returns nothing.
 If called on an object, calls C<method_name> on it and returns the result,
 otherwise returns nothing.
 
+=head2 $_call_if_can
+
+  $maybe_an_object->$_call_if_can(name => @args);
+
+If called on an object, calls C<can> on it; if that returns true, then
+calls C<method_name> on it and returns the result; if any condition is false
+returns nothing.
+
 =head1 SEE ALSO
 
 I gave a lightning talk on this module (and L<curry> and L<Import::Into>) at
diff --git a/t/safe_isa.t b/t/safe_isa.t
index 24af78d..943ef17 100644
--- a/t/safe_isa.t
+++ b/t/safe_isa.t
@@ -1,6 +1,6 @@
 use strict;
 use warnings;
-use Test::More tests => 28;
+use Test::More tests => 38;
 
 { package Foo; sub new { bless({}, $_[0]) } }
 { package Bar; our @ISA = qw(Foo); sub bar { $_[1] } }
@@ -41,3 +41,11 @@ is($bar->$_call_if_object(bar => ), undef, 'bar $_call_if_object(bar => undef)')
 is($bar->$_call_if_object(bar => 2), 2, 'bar $_call_if_object(bar => 2)');
 ok(eval { is($blam->$_call_if_object(isa => 'Foo'), undef, 'blam can\'t call anything'); 1 }, 'no boom today');
 ok(eval { is($undef->$_call_if_object(isa => 'Foo'), undef, 'undef can\'t call anything'); 1 }, 'and no boom tomorrow either');
+
+ok($foo->$_call_if_can(isa => 'Foo'), 'foo $_call_if_can(isa => Foo)');
+ok($bar->$_call_if_can(isa => 'Foo'), 'bar $_call_if_can(isa => Foo)');
+ok(eval { is($foo->$_call_if_can(bar => ), undef, 'foo can\'t call bar'); 1 }, 'no boom today');
+is($bar->$_call_if_can(bar => ), undef, 'bar $_call_if_can(bar => ');
+is($bar->$_call_if_can(bar => 2), 2, 'bar $_call_if_can(bar => 2');
+ok(eval { is($blam->$_call_if_can(isa => 'Foo'), undef, 'blam can\'t call anything'); 1 }, 'no boom today');
+ok(eval { is($undef->$_call_if_can(isa => 'Foo'), undef, 'undef can\'t call anything'); 1 }, 'and no boom tomorrow either');