X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSafe%2FIsa.pm;h=651b6ac0e6cbf509755066ed709ed600d2bf5573;hb=d8e51091604eeec2780fb5a15a8bf4912d5b87ef;hp=680a71b232e13f86d88ec5b1c37891d920d8bcc1;hpb=762424c093174a99aea2aa303679e0ae32419a3e;p=p5sagit%2FSafe-Isa.git diff --git a/lib/Safe/Isa.pm b/lib/Safe/Isa.pm index 680a71b..651b6ac 100644 --- a/lib/Safe/Isa.pm +++ b/lib/Safe/Isa.pm @@ -2,23 +2,50 @@ package Safe::Isa; use strict; use warnings FATAL => 'all'; -use Scalar::Util qw(blessed); +use Scalar::Util (); use Exporter 5.57 qw(import); -our $VERSION = '1.000004'; +our $VERSION = '1.000009'; -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); - return unless blessed($obj); + # This is intentionally a truth test, not a defined test, otherwise + # we gratuitously break modules like Scalar::Defer, which would be + # un-perlish. + return unless Scalar::Util::blessed($obj); 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); + return unless $obj->$_call_if_object(can => $method); + 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__ + +=pod =head1 NAME @@ -63,9 +90,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: @@ -108,6 +136,9 @@ class names that you might not want to treat as one (like say "Matt") - the C function from L is a good way to check for something you might be able to call methods on if you want to do that. +We are careful to make sure that scalar/list context is preserved for the +method that is eventually called. + =head1 EXPORTS =head2 $_isa @@ -129,14 +160,17 @@ returns nothing. $maybe_an_object->$_does('Foo'); If called on an object, calls C on it and returns the result, otherwise -returns nothing. +returns nothing. If the C method does not exist, returns nothing rather +than failing. =head2 $_DOES $maybe_an_object->$_DOES('Foo'); If called on an object, calls C on it and returns the result, otherwise -returns nothing. +returns nothing. On perl versions prior to 5.10.0, the built in core C +method doesn't exist. If the method doesn't exist, this will fall back to +calling C just like the core C method. =head2 $_call_if_object @@ -145,6 +179,19 @@ returns nothing. If called on an object, calls C 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 on it; if that returns true, then +calls C 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 and L) at +L. + =head1 AUTHOR mst - Matt S. Trout (cpan:MSTROUT)