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   217138 use 5.006; use strict; use warnings; no warnings qw(void); use utf8; our $VERSION = '0.07';
  3     3   24  
  3     3   13  
  3     3   3  
  3     3   53  
  3         12  
  3         5  
  3         112  
  3         14  
  3         6  
  3         71  
  3         1766  
  3         37  
  3         13  
3 3     3   1291 use Combine::Keys qw/combine_keys/;
  3         48316  
  3         23  
4 3     3   232 use base 'Import::Export';
  3         6  
  3         13125  
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         34 my $s = quotemeta($_[1]);
14 21         320 $_[0] =~ m†^($s)$†;
15             };
16             },
17             HASH => sub {
18             $STRUCT{SAME}($_[1], 'HASH')
19             and ! $STRUCT{ADDR}($_[0], $_[1])
20 13 100       25 ? do {
    100          
21             exists $_[0]->{$_} && exists $_[1]->{$_} && match($_[0]->{$_}, $_[1]->{$_})
22 11   100     34 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     36 ) && $#{$_[0]} == $#{$_[1]})
    100          
36             : 1;
37             },
38             ADDR => sub {
39 28         92 0 + $_[0] == 0 + $_[1];
40             }, # thou shall not pass/work if the object has + overloaded
41             CHECK => sub {
42 10         20 my $t = $STRUCT{REFTYPE}($_[0]);
43 10 100       17 $STRUCT{SAME}($_[1], $t) && $STRUCT{$t}($_[0], $_[1]);
44             },
45             REFTYPE => sub {
46 25         86 eval { $_[0]->[0] }
47             ? 'ARRAY'
48 25 100       26 : eval { $_[0]->{shamed}; 1 }
  16 100       42  
  9         15  
49             ? 'HASH'
50             : 'ADDR';
51             },
52             REF => sub {
53 112         232 my $r = ref($_[0]);
54 112 100 100     411 $r and ((exists $STRUCT{$r} && $r) || 'CHECK') or 'SCALAR';
      100        
55             },
56             SAME => sub {
57 59         86 my $s = $STRUCT{REF}($_[0]);
58 59 100       103 $s eq 'CHECK' && do { $s = $STRUCT{REFTYPE}($_[0]) };
  15         21  
59 59         192 $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   310 );
63             }
64              
65 53 100 100 53 1 16317 sub match { my $o = $STRUCT{REF}($_[0]); $STRUCT{$o}($_[0], $_[1]) or $_[2] && $o eq 'CHECK' && 1 or 0; }
  53   100     107  
      100        
66              
67             __END__