File Coverage

blib/lib/Test/Deep/HashRec.pm
Criterion Covered Total %
statement 50 60 83.3
branch 9 18 50.0
condition 2 4 50.0
subroutine 8 9 88.8
pod 1 1 100.0
total 70 92 76.0


line stmt bran cond sub pod time code
1 1     1   53598 use strict;
  1         12  
  1         34  
2 1     1   7 use warnings;
  1         2  
  1         69  
3              
4             package Test::Deep::HashRec;
5             # ABSTRACT: test hash entries for required and optional fields
6             $Test::Deep::HashRec::VERSION = '0.003';
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   7 use Exporter 'import';
  1         15  
  1         98  
31              
32             our @EXPORT = qw(hashrec);
33              
34 1     1 1 1544 sub hashrec { Test::Deep::HashRec::Object->new(@_) };
35              
36             {
37             package
38             Test::Deep::HashRec::Object;
39              
40 1     1   521 use Test::Deep::Cmp;
  1         613  
  1         3  
41 1     1   360 use Test::Deep::HashElements;
  1         1061  
  1         6  
42              
43             sub init {
44 1     1   8 my ($self, $val) = @_;
45              
46 1 50       4 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     31 $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         2 map {; $_ => 1 } (keys %{ $self->{required} }, keys %{ $self->{optional} })
  3         7  
  1         3  
  1         2  
57             };
58              
59 1         3 $self->{diagnostics} = [];
60              
61 1 50       3 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         2 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         3 return;
71             }
72              
73             sub diagnostics {
74 0     0   0 my ($self, $where, $last) = @_;
75              
76 0         0 (my $error = $self->{diag}) =~ s/^/ /gm;
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   290 my ($self, $got) = @_;
87              
88 1         5 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         3 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         4  
101 1 50       4 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         3  
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             map {; $_ => (exists $self->{required}{$_} ? $self->{required}{$_}
117 1 50       5 : $self->{optional}{$_}) }
118 1         3 grep {; $self->{is_permitted}{$_} }
  1         3  
119             keys %$got
120             );
121              
122 1         6 return Test::Deep::descend(
123             $got,
124             Test::Deep::HashElements->new(\%effective),
125             );
126             }
127              
128             }
129              
130             1;
131              
132             __END__