File Coverage

blib/lib/Test/Deep/HashRec.pm
Criterion Covered Total %
statement 50 60 83.3
branch 8 16 50.0
condition 3 7 42.8
subroutine 8 9 88.8
pod 1 1 100.0
total 70 93 75.2


line stmt bran cond sub pod time code
1 1     1   59892 use strict;
  1         9  
  1         23  
2 1     1   4 use warnings;
  1         2  
  1         42  
3              
4             package Test::Deep::HashRec;
5             # ABSTRACT: test hash entries for required and optional fields
6             $Test::Deep::HashRec::VERSION = '0.002';
7             #pod =func hashrec
8             #pod
9             #pod cmp_deeply(
10             #pod $got,
11             #pod hashrec({
12             #pod required => { count => any(1,2,3), b => ignore() },
13             #pod optional => { name => { first => ignore(), last => ignore() } },
14             #pod }),
15             #pod "we got a valid record",
16             #pod );
17             #pod
18             #pod C returns a Test::Deep comparator that asserts that:
19             #pod
20             #pod =for :list
21             #pod * all required elements are present
22             #pod * nothing other than required and optional elements are present
23             #pod * all present elements match the comparator given for them
24             #pod
25             #pod If you pass a true C argument, then unknown elements will be
26             #pod permitted, and their values ignored.
27             #pod
28             #pod =cut
29              
30 1     1   4 use Exporter 'import';
  1         1  
  1         67  
31              
32             our @EXPORT = qw(hashrec);
33              
34 1     1 1 1572 sub hashrec { Test::Deep::HashRec::Object->new(@_) };
35              
36             {
37             package
38             Test::Deep::HashRec::Object;
39              
40 1     1   398 use Test::Deep::Cmp;
  1         530  
  1         3  
41 1     1   367 use Test::Deep::HashElements;
  1         1109  
  1         6  
42              
43             sub init {
44 1     1   8 my ($self, $val) = @_;
45              
46 1 50       5 Carp::confess("argument to hashrec must be a hash reference")
47             unless ref $val eq 'HASH';
48              
49 1         4 my %copy = %$val;
50              
51 1   50     29 $self->{required} = delete $copy{required} || {};
52 1   50     4 $self->{optional} = delete $copy{optional} || {};
53 1         3 $self->{allow_unknown} = delete $copy{allow_unknown};
54              
55             $self->{is_permitted} = {
56 1         1 map {; $_ => 1 } (keys %{ $self->{required} }, keys %{ $self->{optional} })
  3         7  
  1         4  
  1         3  
57             };
58              
59 1         3 $self->{diagnostics} = [];
60              
61 1 50       4 Carp::confess("unknown arguments to hashrec: " . join q{, }, keys %copy)
62             if keys %copy;
63              
64 2         5 my @dupes = grep {; exists $self->{required}{$_} }
65 1         1 keys %{ $self->{optional} };
  1         3  
66              
67 1 50       3 Carp::confess("Keys found in both optional and required: @dupes")
68             if @dupes;
69              
70 1         2 return;
71             }
72              
73             sub diagnostics {
74 0     0   0 my ($self, $where, $last) = @_;
75              
76 0         0 my $error = $self->{diag} =~ s/^/ /rgm;
77 0         0 my $diag = <
78             In hash record $where
79             $error
80             EOM
81              
82 0         0 return $diag;
83             }
84              
85             sub descend {
86 1     1   242 my ($self, $got) = @_;
87              
88 1         3 undef $self->{diag};
89              
90 1 50       4 unless (ref $got eq 'HASH') {
91 0         0 $self->{diag} = "Didn't get a hash reference";
92             return
93 0         0 }
94              
95 1         4 my @keys = keys %$got;
96              
97 1         2 my @errors;
98              
99 1 50       3 unless ($self->{allow_unknown}) {
100 1         3 my @unknown = grep {; ! exists $self->{is_permitted}{$_} } @keys;
  1         3  
101 1 50       3 if (@unknown) {
102 0         0 push @errors, "Unknown keys found: @unknown";
103             }
104             }
105              
106 1 50       2 if (my @missing = grep {; ! exists $got->{$_} } keys %{ $self->{required}}) {
  1         4  
  1         2  
107 0         0 push @errors, "Missing required keys: @missing";
108             }
109              
110 1 50       4 if (@errors) {
111 0         0 $self->{diag} = join qq{\n}, @errors;
112 0         0 return;
113             }
114              
115             my %effective = (
116 1   33     22 map {; $_ => ($self->{required}{$_} // $self->{optional}{$_}) }
117 1         3 grep {; $self->{is_permitted}{$_} }
  1         2  
118             keys %$got
119             );
120              
121 1         18 return Test::Deep::descend(
122             $got,
123             Test::Deep::HashElements->new(\%effective),
124             );
125             }
126              
127             }
128              
129             1;
130              
131             __END__