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