File Coverage

inc/Test/Deep/HashKeysOnly.pm
Criterion Covered Total %
statement 35 55 63.6
branch 4 10 40.0
condition 2 6 33.3
subroutine 7 15 46.6
pod 0 6 0.0
total 48 92 52.1


line stmt bran cond sub pod time code
1 1     1   5 #line 1
  1         3  
  1         28  
2 1     1   5 use strict;
  1         2  
  1         24  
3             use warnings;
4              
5             package Test::Deep::HashKeysOnly;
6 1     1   5  
  1         1  
  1         6  
7             use Test::Deep::Ref;
8              
9             sub init
10 44     44 0 52 {
11             my $self = shift;
12 44         42  
13 44         107 my %keys;
14 44         184 @keys{@_} = ();
15 44         194 $self->{val} = \%keys;
16             $self->{keys} = [sort @_];
17             }
18              
19             sub descend
20 44     44 0 63 {
21 44         46 my $self = shift;
22             my $hash = shift;
23 44         120  
24 44         77 my $data = $self->data;
25 44         71 my $exp = $self->{val};
26 44         116 my %got;
27             @got{keys %$hash} = ();
28 44         66  
29             my @missing;
30             my @extra;
31 44         169  
32             while (my ($key, $value) = each %$exp)
33 84 50       150 {
34             if (exists $got{$key})
35 84         242 {
36             delete $got{$key};
37             }
38             else
39 0         0 {
40             push(@missing, $key);
41             }
42             }
43 44         56  
44 44 50 33     116 my @diags;
45             if (@missing and (not $self->ignoreMissing))
46 0         0 {
47             push(@diags, "Missing: ".nice_list(\@missing));
48             }
49 44 50 33     118  
50             if (%got and (not $self->ignoreExtra))
51 0         0 {
52             push(@diags, "Extra: ".nice_list([keys %got]));
53             }
54 44 50       106  
55             if (@diags)
56 0         0 {
57 0         0 $data->{diag} = join("\n", @diags);
58             return 0;
59             }
60 44         146  
61             return 1;
62             }
63              
64             sub diagnostics
65 0     0 0   {
66 0           my $self = shift;
67             my ($where, $last) = @_;
68 0 0          
69             my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
70 0            
71 0           my $error = $last->{diag};
72             my $diag = <
73             Comparing hash keys of $where
74             $error
75             EOM
76 0            
77             return $diag;
78             }
79              
80             sub nice_list
81 0     0 0   {
82             my $list = shift;
83 0            
84 0           return join(", ",
85             (map {"'$_'"} sort @$list),
86             );
87             }
88              
89             sub ignoreMissing
90 0     0 0   {
91             return 0;
92             }
93              
94             sub ignoreExtra
95 0     0 0   {
96             return 0;
97             }
98              
99             package Test::Deep::SuperHashKeysOnly;
100 1     1   8  
  1         3  
  1         8  
101             use base 'Test::Deep::HashKeysOnly';
102              
103             sub ignoreMissing
104 0     0     {
105             return 0;
106             }
107              
108             sub ignoreExtra
109 0     0     {
110             return 1;
111             }
112              
113             package Test::Deep::SubHashKeysOnly;
114 1     1   6  
  1         2  
  1         11  
115             use base 'Test::Deep::HashKeysOnly';
116              
117             sub ignoreMissing
118 0     0     {
119             return 1;
120             }
121              
122             sub ignoreExtra
123 0     0     {
124             return 0;
125             }
126              
127             1;