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 2     2   10 #line 1
  2         5  
  2         65  
2 2     2   9 use strict;
  2         5  
  2         72  
3             use warnings;
4              
5             package Test::Deep::HashKeysOnly;
6 2     2   10  
  2         3  
  2         11  
7             use Test::Deep::Ref;
8              
9             sub init
10 6     6 0 9 {
11             my $self = shift;
12 6         10  
13 6         18 my %keys;
14 6         187 @keys{@_} = ();
15 6         29 $self->{val} = \%keys;
16             $self->{keys} = [sort @_];
17             }
18              
19             sub descend
20 6     6 0 11 {
21 6         6 my $self = shift;
22             my $hash = shift;
23 6         27  
24 6         15 my $data = $self->data;
25 6         9 my $exp = $self->{val};
26 6         16 my %got;
27             @got{keys %$hash} = ();
28 6         9  
29             my @missing;
30             my @extra;
31 6         25  
32             while (my ($key, $value) = each %$exp)
33 8 50       17 {
34             if (exists $got{$key})
35 8         25 {
36             delete $got{$key};
37             }
38             else
39 0         0 {
40             push(@missing, $key);
41             }
42             }
43 6         9  
44 6 50 33     20 my @diags;
45             if (@missing and (not $self->ignoreMissing))
46 0         0 {
47             push(@diags, "Missing: ".nice_list(\@missing));
48             }
49 6 50 33     20  
50             if (%got and (not $self->ignoreExtra))
51 0         0 {
52             push(@diags, "Extra: ".nice_list([keys %got]));
53             }
54 6 50       17  
55             if (@diags)
56 0         0 {
57 0         0 $data->{diag} = join("\n", @diags);
58             return 0;
59             }
60 6         22  
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 2     2   12  
  2         4  
  2         17  
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 2     2   12  
  2         4  
  2         7  
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;