File Coverage

blib/lib/Config/Validator.pm
Criterion Covered Total %
statement 333 417 79.8
branch 204 302 67.5
condition 46 71 64.7
subroutine 36 41 87.8
pod 16 16 100.0
total 635 847 74.9


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: Config/Validator.pm #
4             # #
5             # Description: schema based configuration validation #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package Config::Validator;
14 12     12   10002 use strict;
  12         25  
  12         334  
15 12     12   58 use warnings;
  12         21  
  12         1005  
16             our $VERSION = "1.3";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.36 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 12     12   9298 use No::Worries::Die qw(dief);
  12         255509  
  12         85  
24 12     12   1207 use No::Worries::Export qw(export_control);
  12         27  
  12         75  
25 12     12   1041 use Scalar::Util qw(blessed reftype);
  12         26  
  12         1424  
26 12     12   9213 use URI::Escape qw(uri_escape uri_unescape);
  12         18614  
  12         90617  
27              
28             #
29             # global variables
30             #
31              
32             our(
33             $_Known, # hash reference of known schemas used by _check_type()
34             $_BuiltIn, # hash reference of built-in schemas (to validate schemas)
35             %_RE, # hash of commonly used regular expressions
36             %_DurationScale, # hash of duration suffixes
37             %_SizeScale, # hash of size suffixes
38             );
39              
40             %_DurationScale = (
41             ms => 0.001,
42             s => 1,
43             m => 60,
44             h => 60 * 60,
45             d => 60 * 60 * 24,
46             );
47              
48             %_SizeScale = (
49             b => 1,
50             kb => 1024,
51             mb => 1024 * 1024,
52             gb => 1024 * 1024 * 1024,
53             tb => 1024 * 1024 * 1024 * 1024,
54             );
55              
56             #+++############################################################################
57             # #
58             # regular expressions #
59             # #
60             #---############################################################################
61              
62             sub _init_regexp () {
63 12     12   25 my($label, $byte, $hex4, $ipv4, $ipv6, @tail);
64              
65             # simple ones
66 12         43 $_RE{boolean} = q/true|false/;
67 12         28 $_RE{integer} = q/[\+\-]?\d+/;
68 12         295 $_RE{number} = q/[\+\-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee][\+\-]?\d+)?/;
69 12         29 $_RE{duration} = q/(?:\d+(?:ms|s|m|h|d))+|\d+/;
70 12         31 $_RE{size} = q/\d+[bB]?|(?:\d+\.)?\d+[kKmMgGtT][bB]/;
71             # complex ones
72 12         25 $label = q/[a-zA-Z0-9]([a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?/;
73 12         24 $byte = q/25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d/;
74 12         25 $hex4 = q/[0-9a-fA-F]{1,4}/;
75 12         45 $ipv4 = qq/(($byte)\\.){3}($byte)/;
76 12         147 @tail = (
77             ":",
78             "(:($hex4)?|($ipv4))",
79             ":(($ipv4)|$hex4(:$hex4)?|)",
80             "(:($ipv4)|:$hex4(:($ipv4)|(:$hex4){0,2})|:)",
81             "((:$hex4){0,2}(:($ipv4)|(:$hex4){1,2})|:)",
82             "((:$hex4){0,3}(:($ipv4)|(:$hex4){1,2})|:)",
83             "((:$hex4){0,4}(:($ipv4)|(:$hex4){1,2})|:)",
84             );
85 12         25 $ipv6 = $hex4;
86 12         38 foreach my $tail (@tail) {
87 84         249 $ipv6 = "$hex4:($ipv6|$tail)";
88             }
89 12         92 $ipv6 = qq/:(:$hex4){0,5}((:$hex4){1,2}|:$ipv4)|$ipv6/;
90 12         54 $_RE{hostname} = qq/($label\\.)*$label/;
91 12         26 $_RE{ipv4} = $ipv4;
92 12         47 $_RE{ipv6} = $ipv6;
93             # improve some of them
94 12         30 foreach my $name (qw(hostname ipv4 ipv6)) {
95 36         425 $_RE{$name} =~ s/\(/(?:/g;
96             }
97             # compile them all
98 12         58 foreach my $name (keys(%_RE)) {
99 96         6977 $_RE{$name} = qr/^(?:$_RE{$name})$/;
100             }
101             }
102              
103             _init_regexp();
104              
105             #+++############################################################################
106             # #
107             # helper functions #
108             # #
109             #---############################################################################
110              
111             #
112             # stringify any scalar, including undef
113             #
114              
115             sub _string ($) {
116 17     17   29 my($scalar) = @_;
117              
118 17 50       111 return(defined($scalar) ? "$scalar" : "");
119             }
120              
121             #
122             # format an error
123             #
124              
125             sub _errfmt (@);
126             sub _errfmt (@) {
127 570     570   878 my(@errors) = @_;
128 570         664 my($string, $tmp);
129              
130 570 100       1356 return("") unless @errors;
131 330         494 $string = shift(@errors);
132 330         613 foreach my $error (@errors) {
133 297 50       630 $tmp = ref($error) ? _errfmt(@{ $error }) : $error;
  297         707  
134 297 100       849 next unless length($tmp);
135 57         382 $tmp =~ s/^/ /mg;
136 57         192 $string .= "\n" . $tmp;
137             }
138 330         1103 return($string);
139             }
140              
141             #
142             # expand a duration string and return the corresponding number of seconds
143             #
144              
145             sub expand_duration ($) {
146 10     10 1 6725 my($value) = @_;
147 10         18 my($result);
148              
149 10 100       59 if ($value =~ /^(\d+(ms|s|m|h|d))+$/) {
150 7         13 $result = 0;
151 7         37 while ($value =~ /(\d+)(ms|s|m|h|d)/g) {
152 10         60 $result += $1 * $_DurationScale{$2};
153             }
154             } else {
155 3         7 $result = $value;
156             }
157 10         32 return($result);
158             }
159              
160             #
161             # expand a size string and return the corresponding number of bytes
162             #
163              
164             sub expand_size ($) {
165 10     10 1 4522 my($value) = @_;
166              
167 10 100       45 if ($value =~ /^(.+?)([kmgt]?b)$/i) {
168 7         911 return(int($1 * $_SizeScale{lc($2)} + 0.5));
169             } else {
170 3         6 return($value);
171             }
172             }
173              
174             #
175             # test if a boolean is true or false
176             #
177              
178             sub is_true ($) {
179 345     345 1 1522 my($value) = @_;
180              
181 345 100       627 return(undef) unless defined($value);
182 341   100     2564 return($value and not ref($value) and $value eq "true");
183             }
184              
185             sub is_false ($) {
186 5     5 1 10 my($value) = @_;
187              
188 5 100       18 return(undef) unless defined($value);
189 4   100     35 return($value and not ref($value) and $value eq "false");
190             }
191              
192             #
193             # return the given thing as a list
194             #
195              
196             sub listof ($) {
197 5     5 1 10 my($thing) = @_;
198              
199 5 100       17 return() unless defined($thing);
200 4 100       14 return(@{ $thing }) if ref($thing) eq "ARRAY";
  3         16  
201 1         6 return($thing);
202             }
203              
204             #+++############################################################################
205             # #
206             # conversion helper functions #
207             # #
208             #---############################################################################
209              
210             #
211             # string -> hash
212             #
213              
214             sub string2hash ($) {
215 3     3 1 1042 my($string) = @_;
216 3         3 my(%hash);
217              
218 3         12 foreach my $kv (split(/\s+/, $string)) {
219 3 50       42 if ($kv =~ /^([^\=]+)=(.*)$/) {
220 3         11 $hash{uri_unescape($1)} = uri_unescape($2);
221             } else {
222 0         0 dief("invalid hash key=value: %s", $kv);
223             }
224             }
225 3 50       54 return(%hash) if wantarray();
226 0         0 return(\%hash);
227             }
228              
229             #
230             # hash -> string
231             #
232              
233             sub hash2string (@) {
234 5     5 1 15 my(@args) = @_;
235 5         30 my($hash, @kvs);
236              
237 5 100 66     29 if (@args == 1 and ref($args[0]) eq "HASH") {
238 4         6 $hash = $args[0];
239             } else {
240 1         3 $hash = { @args };
241             }
242 5         9 foreach my $key (sort(keys(%{ $hash }))) {
  5         22  
243 5         47 push(@kvs, uri_escape($key) . "=" . uri_escape($hash->{$key}));
244             }
245 5         122 return(join(" ", @kvs));
246             }
247              
248             #
249             # treeify
250             #
251              
252             sub treeify ($);
253             sub treeify ($) {
254 4     4 1 16 my($hash) = @_;
255              
256 4         25 foreach my $key (grep(/-/, keys(%{ $hash }))) {
  4         22  
257 3 50       18 if ($key =~ /^(\w+)-(.+)$/) {
258 3         14 $hash->{$1}{$2} = delete($hash->{$key});
259             } else {
260 0         0 dief("unexpected configuration name: %s", $key);
261             }
262             }
263 4         25 foreach my $value (values(%{ $hash })) {
  4         13  
264 7 100       30 treeify($value) if ref($value) eq "HASH";
265             }
266             }
267              
268             #
269             # return the value of the given option in a treeified hash
270             #
271              
272             sub treeval ($$);
273             sub treeval ($$) {
274 12     12 1 835 my($hash, $name) = @_;
275              
276 12 100       107 return($hash->{$name}) if exists($hash->{$name});
277 4 50       20 if ($name =~ /^(\w+)-(.+)$/) {
278 4 50       16 return() unless $hash->{$1};
279 4         11 return(treeval($hash->{$1}, $2));
280             }
281 0         0 return();
282             }
283              
284             #+++############################################################################
285             # #
286             # built-in schemas #
287             # #
288             #---############################################################################
289              
290             #
291             # check that a type is valid
292             #
293              
294             sub _check_type ($$$);
295             sub _check_type ($$$) {
296 58     58   105 my($valid, $schema, $data) = @_;
297              
298 58 100       262 return() if $data =~ /^[a-z46]+$/;
299 19 50       47 return() if $data =~ /^(ref|isa)\(\*\)$/;
300 19 100       68 return() if $data =~ /^(ref|isa)\([\w\:]+\)$/;
301 16 100       60 if ($data =~ /^(list\??|table)\((.+)\)$/) {
302 7         39 return(_check_type($valid, $schema, $2));
303             }
304 9 50       33 if ($data =~ /^valid\((.+)\)$/) {
305 9 100       37 return() if $_Known->{$1};
306 1         4 return("unknown schema: $1");
307             }
308 0         0 return("unexpected type: $data");
309             }
310              
311             #
312             # schema of a "type"
313             #
314              
315             $_BuiltIn->{type} = {
316             type => "string",
317             match => qr/ ^
318             ( anything # really anything
319             | undef # undef
320             | undefined # "
321             | defined # not undef
322             | string # any string
323             | boolean # either 'true' or 'false'
324             | number # any number
325             | integer # any integer
326             | duration # any duration, i.e. numbers with hms suffixes
327             | size # any size, i.e. number with optional byte-suffix
328             | hostname # host name
329             | ipv4 # IPv4 address
330             | ipv6 # IPv6 address
331             | reference # any reference, blessed or not
332             | ref\(\*\) # "
333             | blessed # any blessed reference
334             | object # "
335             | isa\(\*\) # "
336             | unblessed # any reference which is not blessed
337             | code # a code reference (aka ref(CODE))
338             | regexp # a regular expression (see is_regexp())
339             | list # an homogeneous list
340             | list\(.+\) # idem but with the given subtype
341             | list\?\(.+\) # shortcut: list?(X) means either X or list(X)
342             | table # an homogeneous table
343             | table\(.+\) # idem but with the given subtype
344             | struct # a structure, i.e. a table with known keys
345             | ref\(.+\) # a reference of the given kind
346             | isa\(.+\) # an object of the given kind
347             | valid\(.+\) # something valid according to the named schema
348             ) $ /x,
349             check => \&_check_type,
350             };
351              
352             #
353             # check that a schema is valid
354             #
355              
356             sub _check_schema ($$$);
357             sub _check_schema ($$$) {
358 50     50   81 my($valid, $schema, $data) = @_;
359 50         58 my($field);
360              
361 50         71 $field = "min";
362             goto unexpected if defined($data->{$field})
363 50 100 100     187 and not $data->{type} =~ /^(string|number|integer|list.*|table.*)$/;
364 49         73 $field = "max";
365             goto unexpected if defined($data->{$field})
366 49 50 66     170 and not $data->{type} =~ /^(string|number|integer|list.*|table.*)$/;
367 49         69 $field = "match";
368             goto unexpected if defined($data->{$field})
369 49 50 66     157 and not $data->{type} =~ /^(string|table.*)$/;
370 49         62 $field = "subtype";
371 49 100       186 if ($data->{type} =~ /^(list|table)$/) {
372 1 50       5 goto missing unless defined($data->{$field});
373             } else {
374 48 50       143 goto unexpected if defined($data->{$field});
375             }
376 49         80 $field = "fields";
377 49 100       128 if ($data->{type} =~ /^(struct)$/) {
378 3 50       13 goto missing unless defined($data->{$field});
379             } else {
380 46 50       136 goto unexpected if defined($data->{$field});
381             }
382 49         108 return();
383             unexpected:
384             return(sprintf("unexpected schema field for type %s: %s",
385 1         5 $data->{type}, $field));
386             missing:
387             return(sprintf("missing schema field for type %s: %s",
388 0         0 $data->{type}, $field));
389             }
390              
391             #
392             # schema of a "schema"
393             #
394              
395             $_BuiltIn->{schema} = {
396             type => "struct",
397             fields => {
398             type => { type => "list?(valid(type))" },
399             subtype => { type => "valid(schema)", optional => "true" },
400             fields => { type => "table(valid(schema))", optional => "true" },
401             optional => { type => "boolean", optional => "true" },
402             min => { type => "number", optional => "true" },
403             max => { type => "number", optional => "true" },
404             match => { type => "regexp", optional => "true" },
405             check => { type => "code", optional => "true" },
406             },
407             check => \&_check_schema,
408             };
409              
410             #+++############################################################################
411             # #
412             # options helpers #
413             # #
414             #---############################################################################
415              
416             #
417             # schema -> options
418             #
419              
420             sub _options ($$$@);
421             sub _options ($$$@) {
422 0     0   0 my($valid, $schema, $type, @path) = @_;
423 0         0 my(@list);
424              
425 0   0     0 $type ||= $schema->{type};
426             # terminal
427 0 0       0 return(join("-", @path) . "=s") if $type eq "string";
428 0 0       0 return(join("-", @path) . "=f") if $type eq "number";
429 0 0       0 return(join("-", @path) . "=i") if $type eq "integer";
430 0 0       0 return(join("-", @path) . "!") if $type eq "boolean";
431             # assumed to come from strings
432 0 0 0     0 return(join("-", @path) . "=s")
      0        
433             if $type =~ /^isa\(.+\)$/
434             or $type eq "table(string)"
435             or $type =~ /^(duration|hostname|ipv[46]|regexp|size)$/;
436             # recursion
437 0 0       0 if ($type =~ /^list\?\((.+)\)$/) {
438 0         0 return(map($_ . "\@", _options($valid, $schema, $1, @path)));
439             }
440 0 0       0 if ($type =~ /^valid\((.+)\)$/) {
441 0 0       0 dief("options(): unknown schema: %s", $1) unless $valid->{$1};
442 0         0 return(_options($valid, $valid->{$1}, undef, @path));
443             }
444 0 0       0 if ($type eq "struct") {
445 0         0 foreach my $field (keys(%{ $schema->{fields} })) {
  0         0  
446 0         0 push(@list, _options($valid, $schema->{fields}{$field},
447             undef, @path, $field));
448             }
449 0         0 return(@list);
450             }
451             # unsupported
452 0         0 dief("options(): unsupported type: %s", $type);
453             }
454              
455             #
456             # treat the given options as mutually exclusive
457             #
458              
459             sub mutex ($@) {
460 0     0 1 0 my($hash, @options) = @_;
461 0         0 my(@list);
462              
463 0         0 foreach my $opt (@options) {
464 0 0       0 next unless defined(treeval($hash, $opt));
465 0         0 push(@list, $opt);
466 0 0       0 dief("options %s and %s are mutually exclusive", @list) if @list == 2;
467             }
468             }
469              
470             #
471             # if the first option is set, all the others are required
472             #
473              
474             sub reqall ($$@) {
475 0     0 1 0 my($hash, $opt1, @options) = @_;
476              
477 0 0 0     0 return unless not defined($opt1) or defined(treeval($hash, $opt1));
478 0         0 foreach my $opt2 (@options) {
479 0 0       0 next if defined(treeval($hash, $opt2));
480 0 0       0 dief("option %s requires option %s", $opt1, $opt2) if defined($opt1);
481 0         0 dief("option %s is required", $opt2);
482             }
483             }
484              
485             #
486             # if the first option is set, one at least of the others is required
487             #
488              
489             sub reqany ($$@) {
490 0     0 1 0 my($hash, $opt1, @options) = @_;
491 0         0 my($req);
492              
493 0 0 0     0 return unless not defined($opt1) or defined(treeval($hash, $opt1));
494 0         0 foreach my $opt2 (@options) {
495 0 0       0 return if defined(treeval($hash, $opt2));
496             }
497 0 0       0 if (@options <= 2) {
498 0         0 $req = join(" or ", @options);
499             } else {
500 0         0 push(@options, join(" or ", splice(@options, -2)));
501 0         0 $req = join(", ", @options);
502             }
503 0 0       0 dief("option %s requires option %s", $opt1, $req) if defined($opt1);
504 0         0 dief("option %s is required", $req);
505             }
506              
507             #+++############################################################################
508             # #
509             # traverse helpers #
510             # #
511             #---############################################################################
512              
513             #
514             # traverse data
515             #
516              
517             sub _traverse_list ($$$$$$@) {
518 1     1   4 my($callback, $valid, $schema, $reftype, $subtype, $data, @path) = @_;
519              
520 1 50       3 return unless $reftype eq "ARRAY";
521 1         2 foreach my $val (@{ $data }) {
  1         3  
522 1         12 _traverse($callback, $valid, $schema, $subtype,
523             $val, @path, 0);
524             }
525             }
526              
527             sub _traverse_table ($$$$$$@) {
528 1     1   3 my($callback, $valid, $schema, $reftype, $subtype, $data, @path) = @_;
529              
530 1 50       4 return unless $reftype eq "HASH";
531 1         4 foreach my $key (keys(%{ $data })) {
  1         4  
532             _traverse($callback, $valid, $schema, $subtype,
533 1         4 $data->{$key}, @path, $key);
534             }
535             }
536              
537             sub _traverse_struct ($$$$$$@) {
538 2     2   6 my($callback, $valid, $schema, $reftype, $subtype, $data, @path) = @_;
539              
540 2 50       6 return unless $reftype eq "HASH";
541 2         3 foreach my $key (keys(%{ $schema->{fields} })) {
  2         8  
542 6 50       16 next unless exists($data->{$key});
543             _traverse($callback, $valid, $schema->{fields}{$key}, undef,
544 6         18 $data->{$key}, @path, $key);
545             }
546             }
547              
548             sub _traverse ($$$$$@);
549             sub _traverse ($$$$$@) {
550 18     18   41 my($callback, $valid, $schema, $type, $data, @path) = @_;
551 18         19 my($reftype, $subtype);
552              
553             # set the type if missing
554 18   66     72 $type ||= $schema->{type};
555             # call the callback and stop unless we are told to continue
556 18 50       55 return unless $callback->($valid, $schema, $type, $_[4], @path);
557             # terminal
558 18 100       25165 return if $type =~ /^(boolean|number|integer)$/;
559 12 50       37 return if $type =~ /^(duration|size|hostname|ipv[46])$/;
560 12 50       26 return if $type =~ /^(undef|undefined|defined|blessed|unblessed)$/;
561 12 50       29 return if $type =~ /^(anything|string|regexp|object|reference|code)$/;
562             # recursion
563 12   100     57 $reftype = reftype($data) || "";
564 12 100       69 if ($type =~ /^valid\((.+)\)$/) {
565 8 50       26 dief("traverse(): unknown schema: %s", $1) unless $valid->{$1};
566 8         28 _traverse($callback, $valid, $valid->{$1}, undef, $_[4], @path);
567 8         24 return;
568             }
569 4 100       11 if ($type eq "struct") {
570 2         7 _traverse_struct($callback, $valid, $schema,
571             $reftype, $subtype, $data, @path);
572 2         6 return;
573             }
574 2 50       7 if ($type =~ /^list$/) {
575             _traverse_list($callback, $valid, $schema->{subtype},
576 0         0 $reftype, $subtype, $data, @path);
577 0         0 return;
578             }
579 2 100       8 if ($type =~ /^list\((.+)\)$/) {
580 1         4 _traverse_list($callback, $valid, $schema,
581             $reftype, $1, $data, @path);
582 1         3 return;
583             }
584 1 50       5 if ($type =~ /^list\?\((.+)\)$/) {
585 0 0       0 if ($reftype eq "ARRAY") {
586 0         0 _traverse_list($callback, $valid, $schema,
587             $reftype, $1, $data, @path);
588             } else {
589 0         0 _traverse($callback, $valid, $schema,
590             $1, $_[4], @path);
591             }
592 0         0 return;
593             }
594 1 50       4 if ($type =~ /^table$/) {
595             _traverse_table($callback, $valid, $schema->{subtype},
596 0         0 $reftype, $subtype, $data, @path);
597 0         0 return;
598             }
599 1 50       7 if ($type =~ /^table\((.+)\)$/) {
600 1         4 _traverse_table($callback, $valid, $schema,
601             $reftype, $1, $data, @path);
602 1         4 return;
603             }
604             # unsupported
605 0         0 dief("traverse(): unsupported type: %s", $type);
606             }
607              
608             #+++############################################################################
609             # #
610             # validation helpers #
611             # #
612             #---############################################################################
613              
614             #
615             # test if something is a regular expression
616             #
617              
618             if ($] >= 5.010) {
619             require re;
620             re->import(qw(is_regexp));
621             } else {
622             *is_regexp = sub { return(ref($_[0]) eq "Regexp") };
623             }
624              
625             #
626             # validate that a value is within a numerical range
627             #
628              
629             sub _validate_range ($$$$) {
630 44     44   94 my($what, $value, $min, $max) = @_;
631              
632 44 100 100     227 return(sprintf("%s is not >= %s: %s", $what, $min, $value))
633             if defined($min) and not $value >= $min;
634 37 100 66     188 return(sprintf("%s is not <= %s: %s", $what, $max, $value))
635             if defined($max) and not $value <= $max;
636 30         64 return();
637             }
638              
639             #
640             # validate a list of homogeneous elements
641             #
642              
643             sub _validate_list ($$$) {
644 13     13   21 my($valid, $schema, $data) = @_;
645 13         18 my(@errors, $index, $element);
646              
647 10         30 @errors = _validate_range("size", scalar(@{ $data }),
648             $schema->{min}, $schema->{max})
649 13 100 66     50 if defined($schema->{min}) or defined($schema->{max});
650 13 100       39 return(@errors) if @errors;
651 9         13 $index = 0;
652 9         14 foreach my $tmp (@{ $data }) {
  9         19  
653 12         18 $element = $tmp; # preserved outside loop
654 12         28 @errors = _validate($valid, $schema->{subtype}, $element);
655 12 100       37 goto invalid if @errors;
656 9         19 $index++;
657             }
658 6         15 return();
659 3         13 invalid:
660             return(sprintf("invalid element %d: %s",
661             $index, _string($element)), \@errors);
662             }
663              
664             #
665             # validate a table of homogeneous elements
666             #
667              
668             sub _validate_table ($$$) {
669 44     44   72 my($valid, $schema, $data) = @_;
670 44         63 my(@errors, $key);
671              
672 6         26 @errors = _validate_range("size", scalar(keys(%{ $data })),
673             $schema->{min}, $schema->{max})
674 44 100 66     268 if defined($schema->{min}) or defined($schema->{max});
675 44 100       122 return(@errors) if @errors;
676 43         64 foreach my $tmp (keys(%{ $data })) {
  43         128  
677 57         75 $key = $tmp; # preserved outside loop
678             @errors = (sprintf("key does not match %s: %s",
679             $schema->{match}, $key))
680 57 100 100     203 if defined($schema->{match}) and not $key =~ $schema->{match};
681 57 100       133 goto invalid if @errors;
682 56         207 @errors = _validate($valid, $schema->{subtype}, $data->{$key});
683 56 100       188 goto invalid if @errors;
684             }
685 37         91 return();
686             invalid:
687             return(sprintf("invalid element %s: %s",
688 6         18 $key, _string($data->{$key})), \@errors);
689             }
690              
691             #
692             # validate a struct, i.e. a hash with known fields
693             #
694              
695             sub _validate_struct ($$$) {
696 59     59   98 my($valid, $schema, $data) = @_;
697 59         73 my(@errors, $key);
698              
699             # check the missing fields
700 59         78 foreach my $tmp (keys(%{ $schema->{fields} })) {
  59         244  
701 429         528 $key = $tmp; # preserved outside loop
702 429 100       921 next if exists($data->{$key});
703 340 100       726 next if is_true($schema->{fields}{$key}{optional});
704 3         16 return(sprintf("missing field: %s", $key));
705             }
706             # check the existing fields
707 56         106 foreach my $tmp (keys(%{ $data })) {
  56         176  
708 90         146 $key = $tmp; # preserved outside loop
709             return(sprintf("unexpected field: %s", $key))
710 90 100       251 unless $schema->{fields}{$key};
711 89         262 @errors = _validate($valid, $schema->{fields}{$key}, $data->{$key});
712 89 100       252 goto invalid if @errors;
713             }
714 52         120 return();
715             invalid:
716             return(sprintf("invalid field %s: %s",
717 3         10 $key, _string($data->{$key})), \@errors);
718             }
719              
720             #
721             # validate something using multiple possible types
722             #
723              
724             sub _validate_multiple ($$$@) {
725 58     58   175 my($valid, $schema, $data, @types) = @_;
726 58         77 my(@errors, %tmpschema, @tmperrors);
727              
728 58         74 %tmpschema = %{ $schema };
  58         199  
729 58         114 foreach my $type (@types) {
730 65         120 $tmpschema{type} = $type;
731 65         187 @tmperrors = _validate($valid, \%tmpschema, $data);
732 65 100       286 return() unless @tmperrors;
733 12         33 push(@errors, [ @tmperrors ]);
734             }
735 5         13 return(sprintf("invalid data (none of the types could be validated): %s",
736             _string($data)), @errors);
737             }
738              
739             #
740             # validate data (non-reference types)
741             #
742              
743             sub _validate_data_nonref ($$) {
744 420     420   614 my($schema, $data) = @_;
745 420         475 my($type, @errors);
746              
747 420         645 $type = $schema->{type};
748 420 100       1557 if ($type eq "string") {
    100          
    50          
749             @errors = _validate_range
750             ("length", length($data), $schema->{min}, $schema->{max})
751 67 100 66     345 if defined($schema->{min}) or defined($schema->{max});
752             @errors = (sprintf("value does not match %s: %s",
753             $schema->{match}, $data))
754             if not @errors and defined($schema->{match})
755 67 100 100     813 and not $data =~ $schema->{match};
      100        
756             } elsif ($type =~ /^(boolean|hostname|ipv[46])$/) {
757 257 100       3211 goto invalid unless $data =~ $_RE{$type};
758             # additional hard-coded checks for host names...
759 136 100       303 if ($type eq "hostname") {
760 13 100       85 goto invalid if ".$data." =~ /\.\d+\./;
761 10         23 @errors = _validate_range("length", length($data), 1, 255);
762             }
763             } elsif ($type =~ /^(integer|number|duration|size)$/) {
764 96 100       1087 goto invalid unless $data =~ $_RE{$type};
765             @errors = _validate_range
766             ("value", $data, $schema->{min}, $schema->{max})
767 70 100 66     376 if defined($schema->{min}) or defined($schema->{max});
768             } else {
769 0         0 return(sprintf("unexpected type: %s", $type));
770             }
771 270 100       929 return() unless @errors;
772 162         903 invalid:
773             return(sprintf("invalid %s: %s", $type, $data), \@errors);
774             }
775              
776             #
777             # validate data (reference types)
778             #
779              
780             ## no critic (ProhibitCascadingIfElse, ProhibitExcessComplexity)
781             sub _validate_data_ref ($$$$) {
782 164     164   280 my($valid, $schema, $data, $reftype) = @_;
783 164         186 my(@errors, %tmpschema, $blessed);
784              
785 164         350 $blessed = defined(blessed($data));
786 164 100       1506 if ($schema->{type} =~ /^(blessed|object|isa\(\*\))$/) {
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
787 7 100       80 goto invalid unless $blessed;
788             } elsif ($schema->{type} eq "unblessed") {
789 0 0       0 goto invalid if $blessed;
790             } elsif ($schema->{type} eq "code") {
791 9 100       116 goto invalid unless $reftype eq "CODE";
792             } elsif ($schema->{type} eq "regexp") {
793 10 100       119 goto invalid unless is_regexp($data);
794             } elsif ($schema->{type} eq "list") {
795 3 50       10 goto invalid unless $reftype eq "ARRAY";
796 3         8 @errors = _validate_list($valid, $schema, $data);
797             } elsif ($schema->{type} =~ /^list\((.+)\)$/) {
798 10 50       25 goto invalid unless $reftype eq "ARRAY";
799 10         11 %tmpschema = %{ $schema };
  10         52  
800 10         43 $tmpschema{subtype} = { type => $1 };
801 10         22 @errors = _validate_list($valid, \%tmpschema, $data);
802             } elsif ($schema->{type} eq "table") {
803 0 0       0 goto invalid unless $reftype eq "HASH";
804 0         0 @errors = _validate_table($valid, $schema, $data);
805             } elsif ($schema->{type} =~ /^table\((.+)\)$/) {
806 45 100       128 goto invalid unless $reftype eq "HASH";
807 44         63 %tmpschema = %{ $schema };
  44         175  
808 44         182 $tmpschema{subtype} = { type => $1 };
809 44         141 @errors = _validate_table($valid, \%tmpschema, $data);
810             } elsif ($schema->{type} eq "struct") {
811 59 50       163 goto invalid unless $reftype eq "HASH";
812 59         138 @errors = _validate_struct($valid, $schema, $data);
813             } elsif ($schema->{type} =~ /^ref\((.+)\)$/) {
814 14 100       170 goto invalid unless $reftype eq $1;
815             } elsif ($schema->{type} =~ /^isa\((.+)\)$/) {
816 7 100 66     95 goto invalid unless $blessed and $data->isa($1);
817             } else {
818 0         0 return(sprintf("unexpected type: %s", $schema->{type}));
819             }
820 133 100       438 return() unless @errors;
821             invalid:
822 52         298 return(sprintf("invalid %s: %s", $schema->{type}, $data), \@errors);
823             }
824             ## use critic
825              
826             #
827             # validate something
828             #
829              
830             sub _validate ($$$);
831             sub _validate ($$$) {
832 851     851   1407 my($valid, $schema, $data) = @_;
833 851         962 my($type, @errors, $reftype, $blessed, %tmpschema);
834              
835 851         1289 $type = $schema->{type};
836             # check multiple types
837 851 50       1901 if (ref($type) eq "ARRAY") {
838 0         0 return(_validate_multiple($valid, $schema, $data, @{ $type }));
  0         0  
839             }
840             # check list?(X)
841 851 100       1919 if ($type =~ /^list\?\((.+)\)$/) {
842 58         237 return(_validate_multiple($valid, $schema, $data, $1, "list($1)"));
843             }
844             # check valid(X)
845 793 100       1729 if ($type =~ /^valid\((.+)\)$/) {
846 105 50       329 return(sprintf("unexpected schema: %s", $1)) unless $valid->{$1};
847 105         325 return(_validate($valid, $valid->{$1}, $data));
848             }
849             # check anything
850 688 100       1392 goto good if $type eq "anything";
851             # check if defined
852 677 100       1337 if ($type =~ /^(undef|undefined)$/) {
853 11 100       41 goto invalid if defined($data);
854 1         4 goto good;
855             }
856 666 100       1387 return(sprintf("invalid %s: ", $type))
857             unless defined($data);
858 652 100       1269 goto good if $type eq "defined";
859 642         1465 $reftype = reftype($data);
860 642 100 100     3569 if ($type =~ /^(string|boolean|number|integer)$/ or
861             $type =~ /^(duration|size|hostname|ipv[46])$/) {
862             # check reference type (for non-reference)
863 438 100       1034 goto invalid if defined($reftype);
864 420         815 @errors = _validate_data_nonref($schema, $data);
865             } else {
866             # check reference type (for reference)
867 204 100       589 goto invalid unless defined($reftype);
868 171 100       409 goto good if $type =~ /^(reference|ref\(\*\))$/;
869 164         369 @errors = _validate_data_ref($valid, $schema, $data, $reftype);
870             }
871 584 100       1875 return(@errors) if @errors;
872             good:
873 399 100       1025 @errors = $schema->{check}->($valid, $schema, $data) if $schema->{check};
874 399 100       1390 return() unless @errors;
875 63         364 invalid:
876             return(sprintf("invalid %s: %s", $type, $data), \@errors);
877             }
878              
879             #+++############################################################################
880             # #
881             # object oriented interface #
882             # #
883             #---############################################################################
884              
885             #
886             # create a validator object
887             #
888              
889             sub new : method {
890 36     36 1 9269 my($class, $self, @errors);
891              
892 36         256 $class = shift(@_);
893 36         72 $self = {};
894             # find out which schema(s) to use
895 36 100       197 if (@_ == 0) {
    100          
    100          
896 1         3 $self->{schema} = $_BuiltIn;
897             } elsif (@_ == 1) {
898 33         109 $self->{schema}{""} = $_[0];
899             } elsif (@_ % 2 == 0) {
900 1         7 $self->{schema} = { @_ };
901             } else {
902 1         7 dief("new(): unexpected number of arguments: %d", scalar(@_));
903             }
904             # validate them
905             {
906 35         56 local $_Known = $self->{schema};
  35         96  
907             @errors = _validate($_BuiltIn, { type => "table(valid(schema))" },
908 35         187 $self->{schema});
909             }
910 35 100       127 dief("new(): invalid schema: %s", _errfmt(@errors)) if @errors;
911             # so far so good!
912 31         57 bless($self, $class);
913 31         87 return($self);
914             }
915              
916             #
917             # convert to a list of options
918             #
919              
920             sub options : method {
921 0     0 1 0 my($self, $schema);
922              
923 0         0 $self = shift(@_);
924             # find out which schema to convert to options
925 0 0       0 if (@_ == 0) {
    0          
926             dief("options(): no default schema")
927 0 0       0 unless $self->{schema}{""};
928 0         0 $schema = $self->{schema}{""};
929             } elsif (@_ == 1) {
930 0         0 $schema = shift(@_);
931             dief("options(): unknown schema: %s", $schema)
932 0 0       0 unless $self->{schema}{$schema};
933 0         0 $schema = $self->{schema}{$schema};
934             } else {
935 0         0 dief("options(): unexpected number of arguments: %d", scalar(@_));
936             }
937             # convert to options
938 0         0 return(_options($self->{schema}, $schema, undef));
939             }
940              
941             #
942             # validate the given data
943             #
944              
945             sub validate : method {
946 489     489 1 204936 my($self, $data, $schema, @errors);
947              
948 489         775 $self = shift(@_);
949             # find out what to validate against
950 489 50       1028 if (@_ == 1) {
    0          
951 489         762 $data = shift(@_);
952             dief("validate(): no default schema")
953 489 50       1358 unless $self->{schema}{""};
954 489         845 $schema = $self->{schema}{""};
955             } elsif (@_ == 2) {
956 0         0 $data = shift(@_);
957 0         0 $schema = shift(@_);
958             dief("validate(): unknown schema: %s", $schema)
959 0 0       0 unless $self->{schema}{$schema};
960 0         0 $schema = $self->{schema}{$schema};
961             } else {
962 0         0 dief("validate(): unexpected number of arguments: %d", scalar(@_));
963             }
964             # validate data
965             {
966 489         547 local $_Known = $self->{schema};
  489         796  
967 489         1095 @errors = _validate($self->{schema}, $schema, $data);
968             }
969 489 100       1751 dief("validate(): %s", _errfmt(@errors)) if @errors;
970             }
971              
972             #
973             # traverse the given data
974             #
975              
976             sub traverse : method {
977 2     2 1 487 my($self, $callback, $data, $schema);
978              
979 2         4 $self = shift(@_);
980             # find out what to traverse
981 2 50       9 if (@_ == 2) {
    50          
982 0         0 $callback = shift(@_);
983 0         0 $data = shift(@_);
984             dief("traverse(): no default schema")
985 0 0       0 unless $self->{schema}{""};
986 0         0 $schema = $self->{schema}{""};
987             } elsif (@_ == 3) {
988 2         3 $callback = shift(@_);
989 2         3 $data = shift(@_);
990 2         4 $schema = shift(@_);
991             dief("traverse(): unknown schema: %s", $schema)
992 2 50       13 unless $self->{schema}{$schema};
993 2         5 $schema = $self->{schema}{$schema};
994             } else {
995 0         0 dief("traverse(): unexpected number of arguments: %d", scalar(@_));
996             }
997             # traverse data
998 2         7 _traverse($callback, $self->{schema}, $schema, undef, $data);
999             }
1000              
1001             #
1002             # export control
1003             #
1004              
1005             sub import : method {
1006 11     11   86 my($pkg, %exported);
1007              
1008 11         25 $pkg = shift(@_);
1009 11         28 foreach my $name (qw(string2hash hash2string treeify treeval
1010             expand_duration expand_size
1011             is_true is_false is_regexp listof
1012             mutex reqall reqany)) {
1013 143         287 $exported{$name}++;
1014             }
1015 11         64 export_control(scalar(caller()), $pkg, \%exported, @_);
1016             }
1017              
1018             1;
1019              
1020             __DATA__