lib/Safe/Isa.pm

   1 package Safe::Isa;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5 use Scalar::Util ();
   6 use Exporter 5.57 qw(import);
   7
   8 our $VERSION = '1.000008';
   9
  10 our @EXPORT = qw($_call_if_object $_isa $_can $_does $_DOES $_call_if_can);
  11
  12 our $_call_if_object = sub {
  13   my ($obj, $method) = (shift, shift);
  14   # This is intentionally a truth test, not a defined test, otherwise
  15   # we gratuitously break modules like Scalar::Defer, which would be
  16   # un-perlish.
  17   return unless Scalar::Util::blessed($obj);
  18   return $obj->$method(@_);
  19 };
  20
  21 our ($_isa, $_can) = map {
  22   my $method = $_;
  23   sub { my $obj = shift; $obj->$_call_if_object($method => @_) }
  24 } qw(isa can);
  25
  26 our $_call_if_can = sub {
  27   my ($obj, $method) = (shift, shift);
  28   return unless $obj->$_call_if_object(can => $method);
  29   return $obj->$method(@_);
  30 };
  31
  32 our $_does = sub {
  33   my $obj = shift;
  34   $obj->$_call_if_can(does => @_);
  35 };
  36
  37 our $_DOES = sub {
  38   my $obj = shift;
  39   return unless Scalar::Util::blessed($obj);
  40   return $obj->DOES(@_)
  41     if $obj->can('DOES');
  42   return $obj->isa(@_);
  43 };
  44
  45 1;
  46 __END__
  47
  48 =pod
  49
  50 =head1 NAME
  51
  52 Safe::Isa - Call isa, can, does and DOES safely on things that may not be objects
  53
  54 =head1 SYNOPSIS
  55
  56   use strict;
  57   use warnings;
  58
  59   { package Foo; sub new { bless({}, $_[0]) } }
  60   { package Bar; our @ISA = qw(Foo); sub bar { 1 } }
  61
  62   my $foo = Foo->new;
  63   my $bar = Bar->new;
  64   my $blam = [ 42 ];
  65
  66   # basic isa usage -
  67
  68   $foo->isa('Foo');  # true
  69   $bar->isa('Foo');  # true
  70   $blam->isa('Foo'); # BOOM
  71
  72   $foo->can('bar');  # false
  73   $bar->can('bar');  # true
  74   $blam->can('bar'); # BOOM
  75
  76   # Safe::Isa usage -
  77
  78   use Safe::Isa;
  79
  80   $foo->$_isa('Foo');  # true
  81   $bar->$_isa('Foo');  # true
  82   $blam->$_isa('Foo'); # false, no boom today
  83
  84   $foo->$_can('bar');  # false
  85   $bar->$_can('bar');  # true
  86   $blam->$_can('bar'); # false, no boom today
  87
  88 Similarly:
  89
  90   $maybe_an_object->$_does('RoleName'); # true or false, no boom today
  91   $maybe_an_object->$_DOES('RoleName'); # true or false, no boom today
  92
  93 And just in case we missed a method or two:
  94
  95   $maybe_an_object->$_call_if_object(name => @args);
  96   $maybe_an_object->$_call_if_can(name => @args);
  97
  98 Or to re-use a previous example for purposes of explication:
  99
 100   $foo->$_call_if_object(isa => 'Foo');  # true
 101   $bar->$_call_if_object(isa => 'Foo');  # true
 102   $blam->$_call_if_object(isa => 'Foo'); # false, no boom today
 103
 104 =head1 DESCRIPTION
 105
 106 How many times have you found yourself writing:
 107
 108   if ($obj->isa('Something')) {
 109
 110 and then shortly afterwards cursing and changing it to:
 111
 112   if (Scalar::Util::blessed($obj) and $obj->isa('Something')) {
 113
 114 Right. That's why this module exists.
 115
 116 Since perl allows us to provide a subroutine reference or a method name to
 117 the -> operator when used as a method call, and a subroutine doesn't require
 118 the invocant to actually be an object, we can create safe versions of isa,
 119 can and friends by using a subroutine reference that only tries to call the
 120 method if it's used on an object. So:
 121
 122   my $isa_Foo = $maybe_an_object->$_call_if_object(isa => 'Foo');
 123
 124 is equivalent to
 125
 126   my $isa_Foo = do {
 127     if (Scalar::Util::blessed($maybe_an_object)) {
 128       $maybe_an_object->isa('Foo');
 129     } else {
 130       undef;
 131     }
 132   };
 133
 134 Note that we don't handle trying class names, because many things are valid
 135 class names that you might not want to treat as one (like say "Matt") - the
 136 C<is_module_name> function from L<Module::Runtime> is a good way to check for
 137 something you might be able to call methods on if you want to do that.
 138
 139 We are careful to make sure that scalar/list context is preserved for the
 140 method that is eventually called.
 141
 142 =head1 EXPORTS
 143
 144 =head2 $_isa
 145
 146   $maybe_an_object->$_isa('Foo');
 147
 148 If called on an object, calls C<isa> on it and returns the result, otherwise
 149 returns nothing.
 150
 151 =head2 $_can
 152
 153   $maybe_an_object->$_can('Foo');
 154
 155 If called on an object, calls C<can> on it and returns the result, otherwise
 156 returns nothing.
 157
 158 =head2 $_does
 159
 160   $maybe_an_object->$_does('Foo');
 161
 162 If called on an object, calls C<does> on it and returns the result, otherwise
 163 returns nothing.
 164
 165 =head2 $_DOES
 166
 167   $maybe_an_object->$_DOES('Foo');
 168
 169 If called on an object, calls C<DOES> on it and returns the result, otherwise
 170 returns nothing.
 171
 172 =head2 $_call_if_object
 173
 174   $maybe_an_object->$_call_if_object(method_name => @args);
 175
 176 If called on an object, calls C<method_name> on it and returns the result,
 177 otherwise returns nothing.
 178
 179 =head2 $_call_if_can
 180
 181   $maybe_an_object->$_call_if_can(name => @args);
 182
 183 If called on an object, calls C<can> on it; if that returns true, then
 184 calls C<method_name> on it and returns the result; if any condition is false
 185 returns nothing.
 186
 187 =head1 SEE ALSO
 188
 189 I gave a lightning talk on this module (and L<curry> and L<Import::Into>) at
 190 L<YAPC::NA 2013|https://www.youtube.com/watch?v=wFXWV2yY7gE&t=46m05s>.
 191
 192 =head1 AUTHOR
 193
 194 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 195
 196 =head1 CONTRIBUTORS
 197
 198 None yet. Well volunteered? :)
 199
 200 =head1 COPYRIGHT
 201
 202 Copyright (c) 2012 the Safe::Isa L</AUTHOR> and L</CONTRIBUTORS>
 203 as listed above.
 204
 205 =head1 LICENSE
 206
 207 This library is free software and may be distributed under the same terms
 208 as perl itself.
 209
 210 =cut