File Coverage

blib/lib/Check/ISA.pm
Criterion Covered Total %
statement 59 60 98.3
branch 22 24 91.6
condition 21 24 87.5
subroutine 14 14 100.0
pod 5 6 83.3
total 121 128 94.5


line stmt bran cond sub pod time code
1             package Check::ISA;
2              
3 2     2   26024 use strict;
  2         2  
  2         45  
4 2     2   6 use warnings;
  2         2  
  2         48  
5              
6 2     2   6 use Scalar::Util qw(blessed);
  2         8  
  2         176  
7              
8 2         14 use Sub::Exporter -setup => {
9             exports => [qw(obj obj_does inv inv_does obj_can inv_can)],
10             groups => {
11             default => [qw(obj obj_does inv)],
12             },
13 2     2   906 };
  2         17158  
14              
15 2     2   593 use constant CAN_HAS_DOES => not not UNIVERSAL->can("DOES");
  2         2  
  2         128  
16 2     2   7 use warnings::register;
  2         1  
  2         214  
17              
18             our $VERSION = "0.09";
19              
20             sub extract_io {
21 20     20 0 16 my $glob = shift;
22              
23             # handle the case of a string like "STDIN"
24             # STDIN->print is actually:
25             # const(PV "STDIN") sM/BARE
26             # method_named(PV "print")
27             # so we need to lookup the glob
28 20 100 100     96 if ( defined($glob) and !ref($glob) and length($glob) ) {
      100        
29 2     2   8 no strict 'refs';
  2         2  
  2         451  
30 13         10 $glob = \*{$glob};
  13         30  
31             }
32              
33             # extract the IO
34 20 100       34 if ( ref($glob) eq 'GLOB' ) {
35 17 100       11 if ( defined ( my $io = *{$glob}{IO} ) ) {
  17         35  
36 6         510 require IO::Handle;
37 6         4396 return $io;
38             }
39             }
40              
41 14         47 return;
42             }
43              
44             sub obj ($;$); # predeclare, it's recursive
45              
46             sub obj ($;$) {
47 11     11 1 503 my ($object_or_filehandle, $class) = @_;
48              
49 11 100 100     29 my $object = blessed($object_or_filehandle)
50             ? $object_or_filehandle
51             : extract_io($object_or_filehandle) || return;
52              
53 7 100       13 if ( defined $class ) {
54 4         9 $object->isa($class);
55             } else {
56 3         8 return 1; # return $object? what if it's overloaded?
57             }
58             }
59              
60             sub obj_does ($;$) {
61 4     4 1 503 my ($object_or_filehandle, $class_or_role) = @_;
62              
63 4 50 0     10 my $object = blessed($object_or_filehandle)
64             ? $object_or_filehandle
65             : extract_io($object_or_filehandle) || return;
66              
67 4 50       7 if (defined $class_or_role) {
68 4         3 if (CAN_HAS_DOES) {
69             # we can be faster in 5.10
70 4         11 $object->DOES($class_or_role);
71             } else {
72             my $method = $object->can("DOES") || "isa";
73             $object->$method($class_or_role);
74             }
75             } else {
76 0         0 return 1; # return $object? what if it's overloaded?
77             }
78             }
79              
80             sub inv ($;$) {
81 28     28 1 843 my ( $inv, $class_or_role ) = @_;
82              
83 28 100       55 if (blessed($inv)) {
84 1         2 return obj_does($inv, $class_or_role);
85             } else {
86             # we check just for scalar keys on the stash because:
87             # sub Foo::Bar::gorch {}
88             # Foo->can("isa") # true
89             # Bar->can("isa") # false
90             # this means that 'Foo' is a valid invocant, but Bar is not
91              
92 27 100 100     154 if (!ref($inv)
      100        
      66        
93             and
94             defined $inv
95             and
96             length($inv)
97             and
98 2     2   7 do { no strict 'refs'; scalar keys %{$inv . "::"} }
  2         2  
  2         285  
  22         16  
  22         61  
99             ) {
100             # it's considered a class name as far as gv_fetchmethod is concerned
101             # even if the class def is empty
102 13 100       16 if (defined $class_or_role) {
103 9         5 if (CAN_HAS_DOES) {
104             # we can be faster in 5.10
105 9         39 $inv->DOES($class_or_role);
106             } else {
107             my $method = $inv->can("DOES") || "isa";
108             $inv->$method($class_or_role);
109             }
110             } else {
111 4         29 return 1; # $inv is always true, so not a problem, but that would be inconsistent
112             }
113             } else {
114 14         41 return;
115             }
116             }
117             }
118              
119             sub obj_can ($;$) {
120 16     16 1 15 my ( $obj, $method ) = @_;
121 16 100 100     49 (blessed($obj) ? $obj : extract_io($obj) || return)->can($method);
122             }
123              
124             sub inv_can ($;$) {
125 7     7 1 8 my ( $inv, $method ) = @_;
126 7 100 100     8 obj_can($inv, $method) || inv($inv) && $inv->can($method);
127             }
128              
129             __PACKAGE__
130              
131             __END__