Initial import of code

diff --git a/Changes b/Changes
new file mode 100644 (file)
index 0000000..7185c76
--- /dev/null
+++ b/Changes
@@ -0,0 +1 @@
+  - Initial release

diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
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 (file)
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<isa> on it and returns the result, otherwise
+returns nothing.
+
+=head2 $_can
+
+  $maybe_an_object->$_can('Foo');
+
+If called on an object, calls C<can> on it and returns the result, otherwise
+returns nothing.
+
+=head2 $_does
+
+  $maybe_an_object->$_does('Foo');
+
+If called on an object, calls C<does> on it and returns the result, otherwise
+returns nothing.
+
+=head2 $_DOES
+
+  $maybe_an_object->$_DOES('Foo');
+
+If called on an object, calls C<DOES> 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<method_name> on it and returns the result,
+otherwise returns nothing.
+
+=head1 AUTHOR
+
+mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
+
+=head1 CONTRIBUTORS
+
+None yet. Well volunteered? :)
+
+=head1 COPYRIGHT
+
+Copyright (c) 2012 the Safe::Isa L</AUTHOR> and L</CONTRIBUTORS>
+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 (file)
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) <mst@shadowcat.co.uk>';
+
+1;

diff --git a/t/safe_isa.t b/t/safe_isa.t
new file mode 100644 (file)
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;