File Coverage

blib/lib/match/smart.pm
Criterion Covered Total %
statement 98 100 98.0
branch 64 68 94.1
condition 17 17 100.0
subroutine 24 24 100.0
pod 1 1 100.0
total 204 210 97.1


line stmt bran cond sub pod time code
1             package match::smart;
2              
3 2     2   72738 use 5.006001;
  2         19  
4 2     2   11 use strict;
  2         4  
  2         40  
5 2     2   12 use warnings;
  2         4  
  2         67  
6              
7 2     2   10 use B qw();
  2         32  
  2         43  
8 2     2   509 use Exporter::Tiny;
  2         3434  
  2         14  
9 2     2   307 use List::Util 1.33 qw( any all );
  2         38  
  2         207  
10 2     2   14 use Scalar::Util qw( blessed looks_like_number refaddr );
  2         5  
  2         161  
11              
12             BEGIN {
13 2     2   7 $match::smart::AUTHORITY = 'cpan:TOBYINK';
14 2         179 $match::smart::VERSION = '0.011';
15             }
16              
17             our @ISA = qw( Exporter::Tiny );
18             our @EXPORT = qw( M );
19             our @EXPORT_OK = qw( match );
20              
21             sub match {
22 2     2   15 no warnings qw( uninitialized numeric );
  2         4  
  2         2262  
23            
24 1110     1110 1 142213 my ( $a, $b, $seen ) = @_;
25 1110         1662 my $method;
26            
27 1110 100       2267 return !defined $a if !defined( $b );
28 1067 100 100     2643 return !!$b->$method( $a, 1 ) if blessed( $b ) && ( $method = _overloaded_smartmatch( $b ) );
29            
30 1057 100 100     2260 if ( blessed($b) and not $b->isa("Regexp") ) {
31 29         106 require Carp;
32 29         3220 Carp::croak( "Smart matching a non-overloaded object breaks encapsulation" );
33             }
34            
35 1028   100     2442 $seen ||= {};
36 1028         1624 my $refb = refaddr($b);
37 1028 100 100     2780 return refaddr( $a ) == $refb if $refb && $seen->{$refb}++;
38            
39 1025 100       1976 if ( ref($b) eq q(ARRAY) ) {
40 118 100       228 if ( ref($a) eq q(ARRAY) ) {
41 63 100       238 return !!0 unless @$a == @$b;
42 53         175 for my $i ( 0 .. $#$a ) {
43 694 100       1160 return !!0 unless match( $a->[$i], $b->[$i], $seen );
44             }
45 43         607 return !!1;
46             }
47            
48 55 100   15   181 return any { exists $a->{$_} } @$b if ref( $a ) eq q(HASH);
  15         173  
49 38 100   20   97 return any { $_ =~ $a } @$b if ref( $a ) eq q(Regexp);
  20         109  
50 32 100   15   108 return any { !defined( $_ ) } @$b if !defined( $a );
  15         92  
51 23     39   112 return any { match( $a, $_ ) } @$b;
  39         115  
52             }
53            
54 907 100       1493 if ( ref($b) eq q(HASH) ) {
55 82 100       1452 return match( [ sort map "$_", keys %$a ], [ sort map "$_", keys %$b ] )
56             if ref($a) eq q(HASH);
57            
58 55 100   33   220 return any { exists $b->{$_} } @$a if ref( $a ) eq q(ARRAY);
  33         245  
59 31 100   59   124 return any { $_ =~ $a } keys %$b if ref( $a ) eq q(Regexp);
  59         225  
60 21 100       66 return !!0 if !defined( $a );
61 17         163 return exists $b->{$a};
62             }
63            
64 825 100       1322 if ( ref($b) eq q(CODE) ) {
65 54 100   24   193 return all { !!$b->($_) } @$a if ref( $a ) eq q(ARRAY);
  24         266  
66 40 100   23   169 return all { !!$b->($_) } keys %$a if ref( $a ) eq q(HASH);
  23         264  
67 26         191 return $b->( $a );
68             }
69            
70 771 100       1301 if ( ref($b) eq q(Regexp) ) {
71 31 100   23   98 return any { $_ =~ $b } @$a if ref( $a ) eq q(ARRAY);
  23         144  
72 22 100   58   97 return any { $_ =~ $b } keys %$a if ref( $a ) eq q(HASH);
  58         224  
73 13         137 return $a =~ $b;
74             }
75            
76 740 100 100     1425 return !!$a->$method( $b, 0 ) if blessed( $a ) && ( $method = _overloaded_smartmatch( $a ) );
77 737 100       1209 return !defined( $b ) if !defined( $a );
78 732 100       1078 return $a == $b if _is_number( $b );
79 597 100 100     853 return $a == $b if _is_number( $a ) && looks_like_number( $b );
80            
81 587         1594 return $a eq $b;
82             }
83              
84             sub _is_number {
85 1329     1329   1691 my $value = shift;
86 1329 100       2109 return if ref $value;
87 1318         2750 my $flags = B::svref_2object( \$value )->FLAGS;
88 1318 100       3843 $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK );
89             }
90              
91             sub _generate_M {
92 1     1   142 require Sub::Infix;
93 1         3 &Sub::Infix::infix( \&match );
94             }
95              
96             unless ( eval 'require re; 1' and exists &re::is_regexp ) {
97             require B;
98             *re::is_regexp = sub {
99             eval { B::svref_2object( $_[0] )->MAGIC->TYPE eq 'r' };
100             };
101             }
102              
103             sub _overloaded_smartmatch {
104 78     78   147 my ( $obj ) = @_;
105 78 100       262 return if re::is_regexp( $obj );
106            
107 46 50       217 if ( $obj->isa( 'Type::Tiny' ) ) {
108 0         0 return $obj->can( 'check' );
109             }
110            
111 46 100       169 if ( my $match = $obj->can( 'MATCH' ) ) {
112 13         73 return $match;
113             }
114            
115 33 50       88 if ( $] lt '5.010' ) { require MRO::Compat; }
  0         0  
116 33         150 else { require mro; }
117            
118 33         51 my @mro = @{ mro::get_linear_isa( ref $obj ) };
  33         155  
119 33         75 for my $class ( @mro ) {
120 33         65 my $name = "$class\::(~~";
121 33         48 my $overload = do {
122 2     2   16 no strict 'refs';
  2         4  
  2         233  
123 33 50       104 exists( &$name ) ? \&$name : undef;
124             };
125 33 50       97 return $overload if defined $overload;
126             }
127            
128 33         109 return;
129             }
130              
131             1;
132              
133             __END__