File Coverage

blib/lib/Data/Sah/Compiler/human/TH/hash.pm
Criterion Covered Total %
statement 164 176 93.1
branch 12 24 50.0
condition n/a
subroutine 26 26 100.0
pod 0 21 0.0
total 202 247 81.7


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 3     3   52 use strict;
  3         34  
4 3     3   14 use warnings;
  3         5  
  3         53  
5 3     3   11 #use Log::Any '$log';
  3         5  
  3         74  
6              
7             use Mo qw(build default);
8 3     3   14 use Role::Tiny::With;
  3         4  
  3         13  
9 3     3   698  
  3         6  
  3         5522  
10             extends 'Data::Sah::Compiler::human::TH';
11             with 'Data::Sah::Compiler::human::TH::Comparable';
12             with 'Data::Sah::Compiler::human::TH::HasElems';
13             with 'Data::Sah::Type::hash';
14              
15             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
16             our $DATE = '2022-08-20'; # DATE
17             our $DIST = 'Data-Sah'; # DIST
18             our $VERSION = '0.912'; # VERSION
19              
20             my ($self, $cd) = @_;
21             my $c = $self->compiler;
22 743     743 0 1515  
23 743         2269 $c->add_ccl($cd, {
24             fmt => ["hash", "hashes"],
25 743         5376 type => 'noun',
26             });
27             }
28              
29             my ($self, $cd) = @_;
30             my $c = $self->compiler;
31              
32 12     12 0 37 $c->add_ccl($cd, {
33 12         36 expr=>1, multi=>1,
34             fmt => "%(modal_verb)s have %s in its %(field)s values"});
35 12         88 }
36              
37             my ($self, $cd) = @_;
38             my $c = $self->compiler;
39             my $cv = $cd->{cl_value};
40              
41 12     12 0 23 my %iargs = %{$cd->{args}};
42 12         34 $iargs{outer_cd} = $cd;
43 12         51 $iargs{schema} = $cv;
44             $iargs{schema_is_normalized} = 0;
45 12         13 $iargs{cache} = $cd->{args}{cache};
  12         153  
46 12         36 my $icd = $c->compile(%iargs);
47 12         24  
48 12         16 $c->add_ccl($cd, {
49 12         28 type => 'list',
50 12         63 fmt => '%(field)s name %(modal_verb)s be',
51             items => [
52             $icd->{ccls},
53             ],
54             vals => [],
55             });
56             }
57 12         82  
58             my ($self, $cd) = @_;
59             my $c = $self->compiler;
60             my $cv = $cd->{cl_value};
61              
62             my %iargs = %{$cd->{args}};
63 18     18 0 33 $iargs{outer_cd} = $cd;
64 18         49 $iargs{schema} = $cv;
65 18         76 $iargs{schema_is_normalized} = 0;
66             $iargs{cache} = $cd->{args}{cache};
67 18         23 my $icd = $c->compile(%iargs);
  18         226  
68 18         53  
69 18         35 $c->add_ccl($cd, {
70 18         28 type => 'list',
71 18         36 fmt => 'each %(field)s %(modal_verb)s be',
72 18         103 items => [
73             $icd->{ccls},
74             ],
75             vals => [],
76             });
77             }
78              
79 18         152 my ($self, $cd) = @_;
80             my $c = $self->compiler;
81             my $cv = $cd->{cl_value};
82              
83             for my $k (sort keys %$cv) {
84             local $cd->{spath} = [@{$cd->{spath}}, $k];
85 47     47 0 84 my $v = $cv->{$k};
86 47         136 my %iargs = %{$cd->{args}};
87 47         220 $iargs{outer_cd} = $cd;
88             $iargs{schema} = $v;
89 47         163 $iargs{schema_is_normalized} = 0;
90 93         128 $iargs{cache} = $cd->{args}{cache};
  93         282  
91 93         187 my $icd = $c->compile(%iargs);
92 93         110 $c->add_ccl($cd, {
  93         1069  
93 93         258 type => 'list',
94 93         149 fmt => '%(field)s %s %(modal_verb)s be',
95 93         158 vals => [$k],
96 93         207 items => [ $icd->{ccls} ],
97 93         510 });
98             }
99             }
100              
101             my ($self, $cd) = @_;
102 93         674 my $c = $self->compiler;
103             my $cv = $cd->{cl_value};
104              
105             for my $k (sort keys %$cv) {
106             local $cd->{spath} = [@{$cd->{spath}}, $k];
107             my $v = $cv->{$k};
108 9     9 0 17 my %iargs = %{$cd->{args}};
109 9         26 $iargs{outer_cd} = $cd;
110 9         39 $iargs{schema} = $v;
111             $iargs{schema_is_normalized} = 0;
112 9         23 $iargs{cache} = $cd->{args}{cache};
113 9         16 my $icd = $c->compile(%iargs);
  9         29  
114 9         19 $c->add_ccl($cd, {
115 9         10 type => 'list',
  9         128  
116 9         32 fmt => '%(fields)s whose names match regex pattern %s %(modal_verb)s be',
117 9         23 vals => [$k],
118 9         16 items => [ $icd->{ccls} ],
119 9         32 });
120 9         53 }
121             }
122              
123             my ($self, $cd) = @_;
124             my $c = $self->compiler;
125 9         65  
126             $c->add_ccl($cd, {
127             fmt => q[%(modal_verb)s have required %(fields)s %s],
128             expr => 1,
129             });
130             }
131 45     45 0 89  
132 45         122 my ($self, $cd) = @_;
133             my $c = $self->compiler;
134 45         287  
135             $c->add_ccl($cd, {
136             fmt => q[%(modal_verb)s only have these allowed %(fields)s %s],
137             expr => 1,
138             });
139             }
140              
141 9     9 0 20 my ($self, $cd) = @_;
142 9         25 my $c = $self->compiler;
143              
144 9         60 $c->add_ccl($cd, {
145             fmt => q[%(modal_verb)s only have %(fields)s matching regex pattern %s],
146             expr => 1,
147             });
148             }
149              
150             my ($self, $cd) = @_;
151 9     9 0 19 my $c = $self->compiler;
152 9         25  
153             $c->add_ccl($cd, {
154 9         65 fmt => q[%(modal_verb_neg)s have these forbidden %(fields)s %s],
155             expr => 1,
156             });
157             }
158              
159             my ($self, $cd) = @_;
160             my $c = $self->compiler;
161 9     9 0 18  
162 9         23 $c->add_ccl($cd, {
163             fmt => q[%(modal_verb_neg)s have %(fields)s matching regex pattern %s],
164 9         59 expr => 1,
165             });
166             }
167              
168             my ($self, $cd) = @_;
169             my $c = $self->compiler;
170              
171 9     9 0 18 my $multi = $cd->{cl_is_multi};
172 9         22 $cd->{cl_is_multi} = 0;
173              
174 9         63 my @ccls;
175             for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
176             push @ccls, {
177             fmt => q[%(modal_verb)s contain at most one of these %(fields)s %s],
178             vals => [$cv],
179             };
180             }
181 36     36 0 55 $c->add_ccl($cd, @ccls);
182 36         105 }
183              
184 36         143 my ($self, $cd) = @_;
185 36         60 my $c = $self->compiler;
186              
187 36         55 my $multi = $cd->{cl_is_multi};
188 36 50       87 $cd->{cl_is_multi} = 0;
  0         0  
189 36         147  
190             my @ccls;
191             for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
192             push @ccls, {
193             fmt => q[%(modal_verb)s contain either none or all of these %(fields)s %s],
194 36         105 vals => [$cv],
195             };
196             }
197             $c->add_ccl($cd, @ccls);
198 36     36 0 71 }
199 36         108  
200             my ($self, $cd) = @_;
201 36         155 my $c = $self->compiler;
202 36         70  
203             my $multi = $cd->{cl_is_multi};
204 36         49 $cd->{cl_is_multi} = 0;
205 36 50       83  
  0         0  
206 36         129 my @ccls;
207             for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
208             push @ccls, {
209             fmt => q[%(modal_verb)s contain exactly one of these %(fields)s %s],
210             vals => [$cv],
211 36         106 };
212             }
213             $c->add_ccl($cd, @ccls);
214             }
215 24     24 0 50  
216 24         68 my ($self, $cd) = @_;
217             my $c = $self->compiler;
218 24         104  
219 24         51 my $multi = $cd->{cl_is_multi};
220             $cd->{cl_is_multi} = 0;
221 24         30  
222 24 50       67 my @ccls;
  0         0  
223 24         94 for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
224             push @ccls, {
225             fmt => q[%(modal_verb)s contain between %d and %d of these %(fields)s %s],
226             vals => [$cv->[0], $cv->[1], $cv->[2]],
227             };
228 24         65 }
229             $c->add_ccl($cd, @ccls);
230             }
231              
232 60     60 0 106 my ($self, $cd) = @_;
233 60         148 my $c = $self->compiler;
234              
235 60         254 my $multi = $cd->{cl_is_multi};
236 60         112 $cd->{cl_is_multi} = 0;
237              
238 60         80 my @ccls;
239 60 50       149 for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
  0         0  
240 60         264 if (@{ $cv->[1] } == 1) {
241             push @ccls, {
242             fmt => q[%(field)s %2$s %(modal_verb)s be present before %(field)s %1$s can be present],
243             vals => [$cv->[0], $cv->[1][0]],
244             };
245 60         164 } else {
246             push @ccls, {
247             fmt => q[one of %(fields)s %2$s %(modal_verb)s be present before %(field)s %1$s can be present],
248             vals => $cv,
249 18     18 0 29 multi => 0,
250 18         49 };
251             }
252 18         71 }
253 18         40 $c->add_ccl($cd, @ccls);
254             }
255 18         25  
256 18 50       54 my ($self, $cd) = @_;
  0         0  
257 18 50       23 my $c = $self->compiler;
  18         39  
258 0         0  
259             my $multi = $cd->{cl_is_multi};
260             $cd->{cl_is_multi} = 0;
261              
262             my @ccls;
263 18         73 for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
264             if (@{ $cv->[1] } == 1) {
265             push @ccls, {
266             fmt => q[%(field)s %2$s %(modal_verb)s be present before %(field)s %1$s can be present],
267             vals => [$cv->[0], $cv->[1][0]],
268             };
269             } else {
270 18         56 push @ccls, {
271             fmt => q[all of %(fields)s %2$s %(modal_verb)s be present before %(field)s %1$s can be present],
272             vals => $cv,
273             };
274 18     18 0 27 }
275 18         57 }
276             $c->add_ccl($cd, @ccls);
277 18         73 }
278 18         34  
279             my ($self, $cd) = @_;
280 18         23 my $c = $self->compiler;
281 18 50       46  
  0         0  
282 18 50       48 my $multi = $cd->{cl_is_multi};
  18         42  
283 0         0 $cd->{cl_is_multi} = 0;
284              
285             my @ccls;
286             for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
287             if (@{ $cv->[1] } == 1) {
288 18         67 push @ccls, {
289             fmt => q[%(field)s %1$s %(modal_verb)s be present when %(field)s %2$s is present],
290             vals => [$cv->[0], $cv->[1][0]],
291             };
292             } else {
293             push @ccls, {
294 18         49 fmt => q[%(field)s %1$s %(modal_verb)s be present when one of %(fields)s %2$s is present],
295             vals => $cv,
296             };
297             }
298 24     24 0 54 }
299 24         60 $c->add_ccl($cd, @ccls);
300             }
301 24         102  
302 24         43 my ($self, $cd) = @_;
303             my $c = $self->compiler;
304 24         31  
305 24 50       57 my $multi = $cd->{cl_is_multi};
  0         0  
306 24 50       29 $cd->{cl_is_multi} = 0;
  24         54  
307 0         0  
308             my @ccls;
309             for my $cv ($multi ? @{ $cd->{cl_value} } : ($cd->{cl_value})) {
310             if (@{ $cv->[1] } == 1) {
311             push @ccls, {
312 24         78 fmt => q[%(field)s %1$s %(modal_verb)s be present when %(field)s %2$s is present],
313             vals => [$cv->[0], $cv->[1][0]],
314             };
315             } else {
316             push @ccls, {
317             fmt => q[%(field)s %1$s %(modal_verb)s be present when all of %(fields)s %2$s are present],
318 24         66 vals => $cv,
319             };
320             }
321             }
322 24     24 0 43 $c->add_ccl($cd, @ccls);
323 24         82 }
324              
325 24         96 my ($self, $cd) = @_;
326 24         38  
327             # ignored attributes
328 24         32 delete $cd->{uclset}{'keys.restrict'};
329 24 50       59 delete $cd->{uclset}{'keys.create_default'};
  0         0  
330 24 50       30 }
  24         51  
331 0         0  
332             my ($self, $cd) = @_;
333              
334             # ignored attributes
335             delete $cd->{uclset}{'re_keys.restrict'};
336 24         86 }
337              
338             1;
339             # ABSTRACT: human's type handler for type "hash"
340              
341              
342 24         76 =pod
343              
344             =encoding UTF-8
345              
346 47     47 0 103 =head1 NAME
347              
348             Data::Sah::Compiler::human::TH::hash - human's type handler for type "hash"
349 47         92  
350 47         108 =head1 VERSION
351              
352             This document describes version 0.912 of Data::Sah::Compiler::human::TH::hash (from Perl distribution Data-Sah), released on 2022-08-20.
353              
354 9     9 0 17 =for Pod::Coverage ^(clause_.+|superclause_.+)$
355              
356             =head1 HOMEPAGE
357 9         26  
358             Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
359              
360             =head1 SOURCE
361              
362             Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
363              
364             =head1 AUTHOR
365              
366             perlancar <perlancar@cpan.org>
367              
368             =head1 CONTRIBUTING
369              
370              
371             To contribute, you can send patches by email/via RT, or send pull requests on
372             GitHub.
373              
374             Most of the time, you don't need to build the distribution yourself. You can
375             simply modify the code, then test via:
376              
377             % prove -l
378              
379             If you want to build the distribution (e.g. to try to install it locally on your
380             system), you can install L<Dist::Zilla>,
381             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
382             L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
383             Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
384             that are considered a bug and can be reported to me.
385              
386             =head1 COPYRIGHT AND LICENSE
387              
388             This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <perlancar@cpan.org>.
389              
390             This is free software; you can redistribute it and/or modify it under
391             the same terms as the Perl 5 programming language system itself.
392              
393             =head1 BUGS
394              
395             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
396              
397             When submitting a bug or request, please include a test-file or a
398             patch to an existing test-file that illustrates the bug or desired
399             feature.
400              
401             =cut