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. If the C<does> method does not exist, returns nothing rather
 164 than failing.
 165
 166 =head2 $_DOES
 167
 168   $maybe_an_object->$_DOES('Foo');
 169
 170 If called on an object, calls C<DOES> on it and returns the result, otherwise
 171 returns nothing. On perl versions prior to 5.10.0, the built in core C<DOES>
 172 method doesn't exist. If the method doesn't exist, this will fall back to
 173 calling C<isa> just like the core C<DOES> method.
 174
 175 =head2 $_call_if_object
 176
 177   $maybe_an_object->$_call_if_object(method_name => @args);
 178
 179 If called on an object, calls C<method_name> on it and returns the result,
 180 otherwise returns nothing.
 181
 182 =head2 $_call_if_can
 183
 184   $maybe_an_object->$_call_if_can(name => @args);
 185
 186 If called on an object, calls C<can> on it; if that returns true, then
 187 calls C<method_name> on it and returns the result; if any condition is false
 188 returns nothing.
 189
 190 =head1 SEE ALSO
 191
 192 I gave a lightning talk on this module (and L<curry> and L<Import::Into>) at
 193 L<YAPC::NA 2013|https://www.youtube.com/watch?v=wFXWV2yY7gE&t=46m05s>.
 194
 195 =head1 AUTHOR
 196
 197 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 198
 199 =head1 CONTRIBUTORS
 200
 201 None yet. Well volunteered? :)
 202
 203 =head1 COPYRIGHT
 204
 205 Copyright (c) 2012 the Safe::Isa L</AUTHOR> and L</CONTRIBUTORS>
 206 as listed above.
 207
 208 =head1 LICENSE
 209
 210 This library is free software and may be distributed under the same terms
 211 as perl itself.
 212
 213 =cut