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