File Coverage

blib/lib/Struct/Match.pm
Criterion Covered Total %
statement 43 43 100.0
branch 22 22 100.0
condition 24 24 100.0
subroutine 9 9 100.0
pod 1 1 100.0
total 99 99 100.0


line stmt bran cond sub pod time code
1             package Struct::Match;
2 3     3   184644 use 5.006; use strict; use warnings; no warnings qw(void); use utf8; our $VERSION = '1.00';
  3     3   24  
  3     3   14  
  3     3   23  
  3     3   59  
  3         13  
  3         16  
  3         112  
  3         17  
  3         5  
  3         78  
  3         1710  
  3         67  
  3         14  
3 3     3   1367 use Combine::Keys qw/combine_keys/;
  3         47800  
  3         71  
4 3     3   249 use base 'Import::Export';
  3         6  
  3         1838  
5             our %STRUCT;
6             our %EX = ('match' => ['all'], '%STRUCT' => ['struct', 'all']);
7              
8             BEGIN {
9             %STRUCT = (
10             SCALAR => sub {
11             $STRUCT{SAME}($_[1], 'SCALAR')
12 22 100       34 and do {
13 21         29 my $s = quotemeta($_[1]);
14 21         328 $_[0] =~ m†^($s)$†;
15             };
16             },
17             HASH => sub {
18             $STRUCT{SAME}($_[1], 'HASH')
19             and ! $STRUCT{ADDR}($_[0], $_[1])
20 13 100       30 ? do {
    100          
21             exists $_[0]->{$_} && exists $_[1]->{$_} && match($_[0]->{$_}, $_[1]->{$_})
22 11   100     37 or return for combine_keys($_[0], $_[1]);
      100        
      100        
23 3         13 1;
24             }
25             : 1;
26             },
27             ARRAY => sub {
28             $STRUCT{SAME}($_[1], 'ARRAY')
29             and ! $STRUCT{ADDR}($_[0], $_[1])
30             ? (((
31             grep {
32             exists $_[0][$_] && match($_[0][$_], $_[1][$_])
33             } 0 .. $#{$_[1]}
34             ) == @{$_[0]}
35 14 100 100     37 ) && $#{$_[0]} == $#{$_[1]})
    100          
36             : 1;
37             },
38             ADDR => sub {
39 28         99 0 + $_[0] == 0 + $_[1];
40             }, # thou shall not pass/work if the object has + overloaded
41             CHECK => sub {
42 10         21 my $t = $STRUCT{REFTYPE}($_[0]);
43 10 100       17 $STRUCT{SAME}($_[1], $t) && $STRUCT{$t}($_[0], $_[1]);
44             },
45             REFTYPE => sub {
46 25         93 eval { $_[0]->[0] }
47             ? 'ARRAY'
48 25 100       27 : eval { $_[0]->{shamed}; 1 }
  16 100       40  
  9         18  
49             ? 'HASH'
50             : 'ADDR';
51             },
52             REF => sub {
53 112         137 my $r = ref($_[0]);
54 112 100 100     387 $r and ((exists $STRUCT{$r} && $r) || 'CHECK') or 'SCALAR';
      100        
55             },
56             SAME => sub {
57 59         85 my $s = $STRUCT{REF}($_[0]);
58 59 100       104 $s eq 'CHECK' && do { $s = $STRUCT{REFTYPE}($_[0]) };
  15         21  
59 59         190 $s eq $_[1];
60             },
61             # currently we do not care about CODE|GLOB|REF|LVALUE|FORMAT|IO|VSTRING|Regexp.. other than doing ref address check hushh
62 3     3   303 );
63             }
64              
65 53 100 100 53 1 10368 sub match { my $o = $STRUCT{REF}($_[0]); $STRUCT{$o}($_[0], $_[1]) or $_[2] && $o eq 'CHECK' && 1 or 0; }
  53   100     109  
      100        
66              
67             __END__