From: Matt S Trout Date: Wed, 18 Jul 2012 15:36:05 +0000 (+0000) Subject: Initial import of code X-Git-Tag: v1.000000~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e6995dc62a0d32013c0e8722f98cca789520fce1;p=p5sagit%2FSafe-Isa.git Initial import of code --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..7185c76 --- /dev/null +++ b/Changes @@ -0,0 +1 @@ + - Initial release diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..1dc4da0 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,10 @@ +use strict; +use warnings FATAL => 'all'; +use 5.008001; +use ExtUtils::MakeMaker; +(do 'maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; + +WriteMakefile( + NAME => 'Safe-Isa', + VERSION_FROM => 'lib/Safe/Isa.pm', +); diff --git a/lib/Safe/Isa.pm b/lib/Safe/Isa.pm new file mode 100644 index 0000000..b725f21 --- /dev/null +++ b/lib/Safe/Isa.pm @@ -0,0 +1,161 @@ +package Safe::Isa; + +use strict; +use warnings FATAL => 'all'; +use Scalar::Util qw(blessed); +use base qw(Exporter); + +our $VERSION = '1.000000'; + +our @EXPORT = qw($_call_if_object $_isa $_can $_does $_DOES); + +our $_call_if_object = sub { + my ($obj, $method) = (shift, shift); + return unless blessed($obj); + return $obj->$method(@_); +}; + +our ($_isa, $_can, $_does, $_DOES) = map { + my $method = $_; + sub { my $obj = shift; $obj->$_call_if_object($method => @_) } +} qw(isa can does DOES); + +=head1 NAME + +Safe::Isa - Call isa, can, does and DOES safely on things that may not be objects + +=head1 SYNOPSIS + + use strict; + use warnings; + + { package Foo; sub new { bless({}, $_[0]) } } + { package Bar; our @ISA = qw(Foo); sub bar { 1 } } + + my $foo = Foo->new; + my $bar = Bar->new; + my $blam = [ 42 ]; + + # basic isa usage - + + $foo->isa('Foo'); # true + $bar->isa('Foo'); # true + $blam->isa('Foo'); # BOOM + + $foo->can('bar'); # false + $bar->can('bar'); # true + $blam->can('bar'); # BOOM + + # Safe::Isa usage - + + use Safe::Isa; + + $foo->$_isa('Foo'); # true + $bar->$_isa('Foo'); # true + $blam->$_isa('Foo'); # false, no boom today + + $foo->$_can('bar'); # false + $bar->$_can('bar'); # true + $blam->$_can('bar'); # false, no boom today + +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: + + $maybe_an_object->$_call_if_object(name => @args); + +Or to re-use a previous example for purposes of explication: + + $foo->$_call_if_method(isa => 'Foo'); # true + $bar->$_call_if_method(isa => 'Foo'); # true + $blam->$_call_if_method(isa => 'Foo'); # false, no boom today + +=head1 DESCRIPTION + +How many times have you found yourself writing: + + if ($obj->isa('Something')) { + +and then shortly afterwards cursing and changing it to: + + if (Scalar::Util::blessed($obj) and $obj->isa('Something')) { + +Right. That's why this module exists. + +Since perl allows us to provide a subroutine reference or a method name to +the -> operator when used as a method call, and a subroutine doesn't require +the invocant to actually be an object, we can create safe versions of isa, +can and friends by using a subroutine reference that only tries to call the +method if it's used on an object. So: + + my $isa_Foo = $maybe_an_object->$_call_if_object(isa => 'Foo'); + +is equivalent to + + my $isa_Foo = do { + if (Scalar::Util::blessed($maybe_an_object)) { + $maybe_an_object->isa('Foo'); + } else { + undef; + } + }; + +=head1 EXPORTS + +=head2 $_isa + + $maybe_an_object->$_isa('Foo'); + +If called on an object, calls C on it and returns the result, otherwise +returns nothing. + +=head2 $_can + + $maybe_an_object->$_can('Foo'); + +If called on an object, calls C on it and returns the result, otherwise +returns nothing. + +=head2 $_does + + $maybe_an_object->$_does('Foo'); + +If called on an object, calls C on it and returns the result, otherwise +returns nothing. + +=head2 $_DOES + + $maybe_an_object->$_DOES('Foo'); + +If called on an object, calls C on it and returns the result, otherwise +returns nothing. + +=head2 $_call_if_method + + $maybe_an_object->$_call_if_method(method_name => @args); + +If called on an object, calls C on it and returns the result, +otherwise returns nothing. + +=head1 AUTHOR + +mst - Matt S. Trout (cpan:MSTROUT) + +=head1 CONTRIBUTORS + +None yet. Well volunteered? :) + +=head1 COPYRIGHT + +Copyright (c) 2012 the Safe::Isa L and L +as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. + +=cut diff --git a/maint/Makefile.PL.include b/maint/Makefile.PL.include new file mode 100644 index 0000000..993a293 --- /dev/null +++ b/maint/Makefile.PL.include @@ -0,0 +1,7 @@ +BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } +use lib 'Distar/lib'; +use Distar; + +author 'mst - Matt S. Trout (cpan:MSTROUT) '; + +1; diff --git a/t/safe_isa.t b/t/safe_isa.t new file mode 100644 index 0000000..3829bee --- /dev/null +++ b/t/safe_isa.t @@ -0,0 +1,36 @@ +use strict; +use warnings FATAL => 'all'; +use Test::More; + +{ package Foo; sub new { bless({}, $_[0]) } } +{ package Bar; our @ISA = qw(Foo); sub bar { 1 } } + +my $foo = Foo->new; +my $bar = Bar->new; +my $blam = [ 42 ]; + +# basic isa usage - + +ok($foo->isa('Foo'), 'foo isa Foo'); +ok($bar->isa('Foo'), 'bar isa Foo'); +ok(!eval { $blam->isa('Foo'); 1 }, 'blam goes blam'); + +ok(!$foo->can('bar'), 'foo !can bar'); +ok($bar->can('bar'), 'bar can bar'); +ok(!eval { $blam->can('bar'); 1 }, 'blam goes blam'); + +use Safe::Isa; + +ok($foo->$_isa('Foo'), 'foo $_isa Foo'); +ok($bar->$_isa('Foo'), 'bar $_isa Foo'); +ok(eval { $blam->$_isa('Foo'); 1 }, 'no boom today'); + +ok(!$foo->$_can('bar'), 'foo !$_can bar'); +ok($bar->$_can('bar'), 'bar $_can bar'); +ok(eval { $blam->$_can('bar'); 1 }, 'no boom today'); + +ok($foo->$_call_if_object(isa => 'Foo'), 'foo $_call_if_object(isa => Foo)'); +ok($bar->$_call_if_object(isa => 'Foo'), 'bar $_call_if_object(isa => Foo)'); +ok(eval { $blam->$_call_if_object(isa => 'Foo'); 1 }, 'no boom today'); + +done_testing;