File Coverage

blib/lib/Test/Deep/HashKeysOnly.pm
Criterion Covered Total %
statement 53 55 96.3
branch 9 10 90.0
condition 6 6 100.0
subroutine 13 15 86.6
pod 0 6 0.0
total 81 92 88.0


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