our
$VERSION
=
"1.4"
;
our
$REVISION
=
sprintf
(
"%d.%02d"
,
q$Revision: 1.36 $
=~ /(\d+)\.(\d+)/);
our
(
$_Known
,
$_BuiltIn
,
%_RE
,
%_DurationScale
,
%_SizeScale
,
);
%_DurationScale
= (
ms
=> 0.001,
s
=> 1,
m
=> 60,
h
=> 60 * 60,
d
=> 60 * 60 * 24,
);
%_SizeScale
= (
b
=> 1,
kb
=> 1024,
mb
=> 1024 * 1024,
gb
=> 1024 * 1024 * 1024,
tb
=> 1024 * 1024 * 1024 * 1024,
);
sub
_init_regexp () {
my
(
$label
,
$byte
,
$hex4
,
$ipv4
,
$ipv6
,
@tail
);
$_RE
{boolean} =
q/true|false/
;
$_RE
{integer} =
q/[\+\-]?\d+/
;
$_RE
{number} =
q/[\+\-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee][\+\-]?\d+)?/
;
$_RE
{duration} =
q/(?:\d+(?:ms|s|m|h|d))+|\d+/
;
$_RE
{size} =
q/\d+[bB]?|(?:\d+\.)?\d+[kKmMgGtT][bB]/
;
$label
=
q/[a-zA-Z0-9]([a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?/
;
$byte
=
q/25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d/
;
$hex4
=
q/[0-9a-fA-F]{1,4}/
;
$ipv4
=
qq/(($byte)\\.){3}($byte)/
;
@tail
= (
":"
,
"(:($hex4)?|($ipv4))"
,
":(($ipv4)|$hex4(:$hex4)?|)"
,
"(:($ipv4)|:$hex4(:($ipv4)|(:$hex4){0,2})|:)"
,
"((:$hex4){0,2}(:($ipv4)|(:$hex4){1,2})|:)"
,
"((:$hex4){0,3}(:($ipv4)|(:$hex4){1,2})|:)"
,
"((:$hex4){0,4}(:($ipv4)|(:$hex4){1,2})|:)"
,
);
$ipv6
=
$hex4
;
foreach
my
$tail
(
@tail
) {
$ipv6
=
"$hex4:($ipv6|$tail)"
;
}
$ipv6
=
qq/:(:$hex4){0,5}((:$hex4){1,2}|:$ipv4)|$ipv6/
;
$_RE
{hostname} =
qq/($label\\.)*$label/
;
$_RE
{ipv4} =
$ipv4
;
$_RE
{ipv6} =
$ipv6
;
foreach
my
$name
(
qw(hostname ipv4 ipv6)
) {
$_RE
{
$name
} =~ s/\(/(?:/g;
}
foreach
my
$name
(
keys
(
%_RE
)) {
$_RE
{
$name
} =
qr/^(?:$_RE{$name})$/
;
}
}
_init_regexp();
sub
_string ($) {
my
(
$scalar
) =
@_
;
return
(
defined
(
$scalar
) ?
"$scalar"
:
"<undef>"
);
}
sub
_errfmt (@);
sub
_errfmt (@) {
my
(
@errors
) =
@_
;
my
(
$string
,
$tmp
);
return
(
""
)
unless
@errors
;
$string
=
shift
(
@errors
);
foreach
my
$error
(
@errors
) {
$tmp
=
ref
(
$error
) ? _errfmt(@{
$error
}) :
$error
;
next
unless
length
(
$tmp
);
$tmp
=~ s/^/ /mg;
$string
.=
"\n"
.
$tmp
;
}
return
(
$string
);
}
sub
expand_duration ($) {
my
(
$value
) =
@_
;
my
(
$result
);
if
(
$value
=~ /^(\d+(ms|s|m|h|d))+$/) {
$result
= 0;
while
(
$value
=~ /(\d+)(ms|s|m|h|d)/g) {
$result
+= $1 *
$_DurationScale
{$2};
}
}
else
{
$result
=
$value
;
}
return
(
$result
);
}
sub
expand_size ($) {
my
(
$value
) =
@_
;
if
(
$value
=~ /^(.+?)([kmgt]?b)$/i) {
return
(
int
($1 *
$_SizeScale
{
lc
($2)} + 0.5));
}
else
{
return
(
$value
);
}
}
sub
is_true ($) {
my
(
$value
) =
@_
;
return
(
undef
)
unless
defined
(
$value
);
return
(
$value
and not
ref
(
$value
) and
$value
eq
"true"
);
}
sub
is_false ($) {
my
(
$value
) =
@_
;
return
(
undef
)
unless
defined
(
$value
);
return
(
$value
and not
ref
(
$value
) and
$value
eq
"false"
);
}
sub
listof ($) {
my
(
$thing
) =
@_
;
return
()
unless
defined
(
$thing
);
return
(@{
$thing
})
if
ref
(
$thing
) eq
"ARRAY"
;
return
(
$thing
);
}
sub
string2hash ($) {
my
(
$string
) =
@_
;
my
(
%hash
);
foreach
my
$kv
(
split
(/\s+/,
$string
)) {
if
(
$kv
=~ /^([^\=]+)=(.*)$/) {
$hash
{uri_unescape($1)} = uri_unescape($2);
}
else
{
dief(
"invalid hash key=value: %s"
,
$kv
);
}
}
return
(
%hash
)
if
wantarray
();
return
(\
%hash
);
}
sub
hash2string (@) {
my
(
@args
) =
@_
;
my
(
$hash
,
@kvs
);
if
(
@args
== 1 and
ref
(
$args
[0]) eq
"HASH"
) {
$hash
=
$args
[0];
}
else
{
$hash
= {
@args
};
}
foreach
my
$key
(
sort
(
keys
(%{
$hash
}))) {
push
(
@kvs
, uri_escape(
$key
) .
"="
. uri_escape(
$hash
->{
$key
}));
}
return
(
join
(
" "
,
@kvs
));
}
sub
treeify ($);
sub
treeify ($) {
my
(
$hash
) =
@_
;
foreach
my
$key
(
grep
(/-/,
keys
(%{
$hash
}))) {
if
(
$key
=~ /^(\w+)-(.+)$/) {
$hash
->{$1}{$2} =
delete
(
$hash
->{
$key
});
}
else
{
dief(
"unexpected configuration name: %s"
,
$key
);
}
}
foreach
my
$value
(
values
(%{
$hash
})) {
treeify(
$value
)
if
ref
(
$value
) eq
"HASH"
;
}
}
sub
treeval ($$);
sub
treeval ($$) {
my
(
$hash
,
$name
) =
@_
;
return
(
$hash
->{
$name
})
if
exists
(
$hash
->{
$name
});
if
(
$name
=~ /^(\w+)-(.+)$/) {
return
()
unless
$hash
->{$1};
return
(treeval(
$hash
->{$1}, $2));
}
return
();
}
sub
_check_type ($$$);
sub
_check_type ($$$) {
my
(
$valid
,
$schema
,
$data
) =
@_
;
return
()
if
$data
=~ /^[a-z46]+$/;
return
()
if
$data
=~ /^(
ref
|isa)\(\*\)$/;
return
()
if
$data
=~ /^(
ref
|isa)\([\w\:]+\)$/;
if
(
$data
=~ /^(list\??|table)\((.+)\)$/) {
return
(_check_type(
$valid
,
$schema
, $2));
}
if
(
$data
=~ /^valid\((.+)\)$/) {
return
()
if
$_Known
->{$1};
return
(
"unknown schema: $1"
);
}
return
(
"unexpected type: $data"
);
}
$_BuiltIn
->{type} = {
type
=>
"string"
,
match
=>
qr/ ^
( anything # really anything
| undef # undef
| undefined # "
| defined # not undef
| string # any string
| boolean # either 'true' or 'false'
| number # any number
| integer # any integer
| duration # any duration, i.e. numbers with hms suffixes
| size # any size, i.e. number with optional byte-suffix
| hostname # host name
| ipv4 # IPv4 address
| ipv6 # IPv6 address
| reference # any reference, blessed or not
| ref\(\*\) # "
| blessed # any blessed reference
| object # "
| isa\(\*\) # "
| unblessed # any reference which is not blessed
| code # a code reference (aka ref(CODE))
| regexp # a regular expression (see is_regexp())
| list # an homogeneous list
| list\(.+\) # idem but with the given subtype
| list\?\(.+\) # shortcut: list?(X) means either X or list(X)
| table # an homogeneous table
| table\(.+\) # idem but with the given subtype
| struct # a structure, i.e. a table with known keys
| ref\(.+\) # a reference of the given kind
| isa\(.+\) # an object of the given kind
| valid\(.+\) # something valid according to the named schema
) $ /
x,
check
=> \
&_check_type
,
};
sub
_check_schema ($$$);
sub
_check_schema ($$$) {
my
(
$valid
,
$schema
,
$data
) =
@_
;
my
(
$field
);
$field
=
"min"
;
goto
unexpected
if
defined
(
$data
->{
$field
})
and not
$data
->{type} =~ /^(string|number|integer|list.*|table.*)$/;
$field
=
"max"
;
goto
unexpected
if
defined
(
$data
->{
$field
})
and not
$data
->{type} =~ /^(string|number|integer|list.*|table.*)$/;
$field
=
"match"
;
goto
unexpected
if
defined
(
$data
->{
$field
})
and not
$data
->{type} =~ /^(string|table.*)$/;
$field
=
"subtype"
;
if
(
$data
->{type} =~ /^(list|table)$/) {
goto
missing
unless
defined
(
$data
->{
$field
});
}
else
{
goto
unexpected
if
defined
(
$data
->{
$field
});
}
$field
=
"fields"
;
if
(
$data
->{type} =~ /^(struct)$/) {
goto
missing
unless
defined
(
$data
->{
$field
});
}
else
{
goto
unexpected
if
defined
(
$data
->{
$field
});
}
return
();
unexpected:
return
(
sprintf
(
"unexpected schema field for type %s: %s"
,
$data
->{type},
$field
));
missing:
return
(
sprintf
(
"missing schema field for type %s: %s"
,
$data
->{type},
$field
));
}
$_BuiltIn
->{schema} = {
type
=>
"struct"
,
fields
=> {
type
=> {
type
=>
"list?(valid(type))"
},
subtype
=> {
type
=>
"valid(schema)"
,
optional
=>
"true"
},
fields
=> {
type
=>
"table(valid(schema))"
,
optional
=>
"true"
},
optional
=> {
type
=>
"boolean"
,
optional
=>
"true"
},
min
=> {
type
=>
"number"
,
optional
=>
"true"
},
max
=> {
type
=>
"number"
,
optional
=>
"true"
},
match
=> {
type
=>
"regexp"
,
optional
=>
"true"
},
check
=> {
type
=>
"code"
,
optional
=>
"true"
},
},
check
=> \
&_check_schema
,
};
sub
_options ($$$@);
sub
_options ($$$@) {
my
(
$valid
,
$schema
,
$type
,
@path
) =
@_
;
my
(
@list
);
$type
||=
$schema
->{type};
return
(
join
(
"-"
,
@path
) .
"=s"
)
if
$type
eq
"string"
;
return
(
join
(
"-"
,
@path
) .
"=f"
)
if
$type
eq
"number"
;
return
(
join
(
"-"
,
@path
) .
"=i"
)
if
$type
eq
"integer"
;
return
(
join
(
"-"
,
@path
) .
"!"
)
if
$type
eq
"boolean"
;
return
(
join
(
"-"
,
@path
) .
"=s"
)
if
$type
=~ /^isa\(.+\)$/
or
$type
eq
"table(string)"
or
$type
=~ /^(duration|hostname|ipv[46]|regexp|size)$/;
if
(
$type
=~ /^list\?\((.+)\)$/) {
return
(
map
(
$_
.
"\@"
, _options(
$valid
,
$schema
, $1,
@path
)));
}
if
(
$type
=~ /^valid\((.+)\)$/) {
dief(
"options(): unknown schema: %s"
, $1)
unless
$valid
->{$1};
return
(_options(
$valid
,
$valid
->{$1},
undef
,
@path
));
}
if
(
$type
eq
"struct"
) {
foreach
my
$field
(
keys
(%{
$schema
->{fields} })) {
push
(
@list
, _options(
$valid
,
$schema
->{fields}{
$field
},
undef
,
@path
,
$field
));
}
return
(
@list
);
}
dief(
"options(): unsupported type: %s"
,
$type
);
}
sub
mutex ($@) {
my
(
$hash
,
@options
) =
@_
;
my
(
@list
);
foreach
my
$opt
(
@options
) {
next
unless
defined
(treeval(
$hash
,
$opt
));
push
(
@list
,
$opt
);
dief(
"options %s and %s are mutually exclusive"
,
@list
)
if
@list
== 2;
}
}
sub
reqall ($$@) {
my
(
$hash
,
$opt1
,
@options
) =
@_
;
return
unless
not
defined
(
$opt1
) or
defined
(treeval(
$hash
,
$opt1
));
foreach
my
$opt2
(
@options
) {
next
if
defined
(treeval(
$hash
,
$opt2
));
dief(
"option %s requires option %s"
,
$opt1
,
$opt2
)
if
defined
(
$opt1
);
dief(
"option %s is required"
,
$opt2
);
}
}
sub
reqany ($$@) {
my
(
$hash
,
$opt1
,
@options
) =
@_
;
my
(
$req
);
return
unless
not
defined
(
$opt1
) or
defined
(treeval(
$hash
,
$opt1
));
foreach
my
$opt2
(
@options
) {
return
if
defined
(treeval(
$hash
,
$opt2
));
}
if
(
@options
<= 2) {
$req
=
join
(
" or "
,
@options
);
}
else
{
push
(
@options
,
join
(
" or "
,
splice
(
@options
, -2)));
$req
=
join
(
", "
,
@options
);
}
dief(
"option %s requires option %s"
,
$opt1
,
$req
)
if
defined
(
$opt1
);
dief(
"option %s is required"
,
$req
);
}
sub
_traverse_list ($$$$$$@) {
my
(
$callback
,
$valid
,
$schema
,
$reftype
,
$subtype
,
$data
,
@path
) =
@_
;
return
unless
$reftype
eq
"ARRAY"
;
foreach
my
$val
(@{
$data
}) {
_traverse(
$callback
,
$valid
,
$schema
,
$subtype
,
$val
,
@path
, 0);
}
}
sub
_traverse_table ($$$$$$@) {
my
(
$callback
,
$valid
,
$schema
,
$reftype
,
$subtype
,
$data
,
@path
) =
@_
;
return
unless
$reftype
eq
"HASH"
;
foreach
my
$key
(
keys
(%{
$data
})) {
_traverse(
$callback
,
$valid
,
$schema
,
$subtype
,
$data
->{
$key
},
@path
,
$key
);
}
}
sub
_traverse_struct ($$$$$$@) {
my
(
$callback
,
$valid
,
$schema
,
$reftype
,
$subtype
,
$data
,
@path
) =
@_
;
return
unless
$reftype
eq
"HASH"
;
foreach
my
$key
(
keys
(%{
$schema
->{fields} })) {
next
unless
exists
(
$data
->{
$key
});
_traverse(
$callback
,
$valid
,
$schema
->{fields}{
$key
},
undef
,
$data
->{
$key
},
@path
,
$key
);
}
}
sub
_traverse ($$$$$@);
sub
_traverse ($$$$$@) {
my
(
$callback
,
$valid
,
$schema
,
$type
,
$data
,
@path
) =
@_
;
my
(
$reftype
,
$subtype
);
$type
||=
$schema
->{type};
return
unless
$callback
->(
$valid
,
$schema
,
$type
,
$_
[4],
@path
);
return
if
$type
=~ /^(boolean|number|integer)$/;
return
if
$type
=~ /^(duration|size|hostname|ipv[46])$/;
return
if
$type
=~ /^(
undef
|undefined|
defined
|blessed|unblessed)$/;
return
if
$type
=~ /^(anything|string|regexp|object|reference|code)$/;
$reftype
= reftype(
$data
) ||
""
;
if
(
$type
=~ /^valid\((.+)\)$/) {
dief(
"traverse(): unknown schema: %s"
, $1)
unless
$valid
->{$1};
_traverse(
$callback
,
$valid
,
$valid
->{$1},
undef
,
$_
[4],
@path
);
return
;
}
if
(
$type
eq
"struct"
) {
_traverse_struct(
$callback
,
$valid
,
$schema
,
$reftype
,
$subtype
,
$data
,
@path
);
return
;
}
if
(
$type
=~ /^list$/) {
_traverse_list(
$callback
,
$valid
,
$schema
->{subtype},
$reftype
,
$subtype
,
$data
,
@path
);
return
;
}
if
(
$type
=~ /^list\((.+)\)$/) {
_traverse_list(
$callback
,
$valid
,
$schema
,
$reftype
, $1,
$data
,
@path
);
return
;
}
if
(
$type
=~ /^list\?\((.+)\)$/) {
if
(
$reftype
eq
"ARRAY"
) {
_traverse_list(
$callback
,
$valid
,
$schema
,
$reftype
, $1,
$data
,
@path
);
}
else
{
_traverse(
$callback
,
$valid
,
$schema
,
$1,
$_
[4],
@path
);
}
return
;
}
if
(
$type
=~ /^table$/) {
_traverse_table(
$callback
,
$valid
,
$schema
->{subtype},
$reftype
,
$subtype
,
$data
,
@path
);
return
;
}
if
(
$type
=~ /^table\((.+)\)$/) {
_traverse_table(
$callback
,
$valid
,
$schema
,
$reftype
, $1,
$data
,
@path
);
return
;
}
dief(
"traverse(): unsupported type: %s"
,
$type
);
}
if
($] >= 5.010) {
re->
import
(
qw(is_regexp)
);
}
else
{
*is_regexp
=
sub
{
return
(
ref
(
$_
[0]) eq
"Regexp"
) };
}
sub
_validate_range ($$$$) {
my
(
$what
,
$value
,
$min
,
$max
) =
@_
;
return
(
sprintf
(
"%s is not >= %s: %s"
,
$what
,
$min
,
$value
))
if
defined
(
$min
) and not
$value
>=
$min
;
return
(
sprintf
(
"%s is not <= %s: %s"
,
$what
,
$max
,
$value
))
if
defined
(
$max
) and not
$value
<=
$max
;
return
();
}
sub
_validate_list ($$$) {
my
(
$valid
,
$schema
,
$data
) =
@_
;
my
(
@errors
,
$index
,
$element
);
@errors
= _validate_range(
"size"
,
scalar
(@{
$data
}),
$schema
->{min},
$schema
->{max})
if
defined
(
$schema
->{min}) or
defined
(
$schema
->{max});
return
(
@errors
)
if
@errors
;
$index
= 0;
foreach
my
$tmp
(@{
$data
}) {
$element
=
$tmp
;
@errors
= _validate(
$valid
,
$schema
->{subtype},
$element
);
goto
invalid
if
@errors
;
$index
++;
}
return
();
invalid:
return
(
sprintf
(
"invalid element %d: %s"
,
$index
, _string(
$element
)), \
@errors
);
}
sub
_validate_table ($$$) {
my
(
$valid
,
$schema
,
$data
) =
@_
;
my
(
@errors
,
$key
);
@errors
= _validate_range(
"size"
,
scalar
(
keys
(%{
$data
})),
$schema
->{min},
$schema
->{max})
if
defined
(
$schema
->{min}) or
defined
(
$schema
->{max});
return
(
@errors
)
if
@errors
;
foreach
my
$tmp
(
keys
(%{
$data
})) {
$key
=
$tmp
;
@errors
= (
sprintf
(
"key does not match %s: %s"
,
$schema
->{match},
$key
))
if
defined
(
$schema
->{match}) and not
$key
=~
$schema
->{match};
goto
invalid
if
@errors
;
@errors
= _validate(
$valid
,
$schema
->{subtype},
$data
->{
$key
});
goto
invalid
if
@errors
;
}
return
();
invalid:
return
(
sprintf
(
"invalid element %s: %s"
,
$key
, _string(
$data
->{
$key
})), \
@errors
);
}
sub
_validate_struct ($$$) {
my
(
$valid
,
$schema
,
$data
) =
@_
;
my
(
@errors
,
$key
);
foreach
my
$tmp
(
keys
(%{
$schema
->{fields} })) {
$key
=
$tmp
;
next
if
exists
(
$data
->{
$key
});
next
if
is_true(
$schema
->{fields}{
$key
}{optional});
return
(
sprintf
(
"missing field: %s"
,
$key
));
}
foreach
my
$tmp
(
keys
(%{
$data
})) {
$key
=
$tmp
;
return
(
sprintf
(
"unexpected field: %s"
,
$key
))
unless
$schema
->{fields}{
$key
};
@errors
= _validate(
$valid
,
$schema
->{fields}{
$key
},
$data
->{
$key
});
goto
invalid
if
@errors
;
}
return
();
invalid:
return
(
sprintf
(
"invalid field %s: %s"
,
$key
, _string(
$data
->{
$key
})), \
@errors
);
}
sub
_validate_multiple ($$$@) {
my
(
$valid
,
$schema
,
$data
,
@types
) =
@_
;
my
(
@errors
,
%tmpschema
,
@tmperrors
);
%tmpschema
= %{
$schema
};
foreach
my
$type
(
@types
) {
$tmpschema
{type} =
$type
;
@tmperrors
= _validate(
$valid
, \
%tmpschema
,
$data
);
return
()
unless
@tmperrors
;
push
(
@errors
, [
@tmperrors
]);
}
return
(
sprintf
(
"invalid data (none of the types could be validated): %s"
,
_string(
$data
)),
@errors
);
}
sub
_validate_data_nonref ($$) {
my
(
$schema
,
$data
) =
@_
;
my
(
$type
,
@errors
);
$type
=
$schema
->{type};
if
(
$type
eq
"string"
) {
@errors
= _validate_range
(
"length"
,
length
(
$data
),
$schema
->{min},
$schema
->{max})
if
defined
(
$schema
->{min}) or
defined
(
$schema
->{max});
@errors
= (
sprintf
(
"value does not match %s: %s"
,
$schema
->{match},
$data
))
if
not
@errors
and
defined
(
$schema
->{match})
and not
$data
=~
$schema
->{match};
}
elsif
(
$type
=~ /^(boolean|hostname|ipv[46])$/) {
goto
invalid
unless
$data
=~
$_RE
{
$type
};
if
(
$type
eq
"hostname"
) {
goto
invalid
if
".$data."
=~ /\.\d+\./;
@errors
= _validate_range(
"length"
,
length
(
$data
), 1, 255);
}
}
elsif
(
$type
=~ /^(integer|number|duration|size)$/) {
goto
invalid
unless
$data
=~
$_RE
{
$type
};
@errors
= _validate_range
(
"value"
,
$data
,
$schema
->{min},
$schema
->{max})
if
defined
(
$schema
->{min}) or
defined
(
$schema
->{max});
}
else
{
return
(
sprintf
(
"unexpected type: %s"
,
$type
));
}
return
()
unless
@errors
;
invalid:
return
(
sprintf
(
"invalid %s: %s"
,
$type
,
$data
), \
@errors
);
}
sub
_validate_data_ref ($$$$) {
my
(
$valid
,
$schema
,
$data
,
$reftype
) =
@_
;
my
(
@errors
,
%tmpschema
,
$blessed
);
$blessed
=
defined
(blessed(
$data
));
if
(
$schema
->{type} =~ /^(blessed|object|isa\(\*\))$/) {
goto
invalid
unless
$blessed
;
}
elsif
(
$schema
->{type} eq
"unblessed"
) {
goto
invalid
if
$blessed
;
}
elsif
(
$schema
->{type} eq
"code"
) {
goto
invalid
unless
$reftype
eq
"CODE"
;
}
elsif
(
$schema
->{type} eq
"regexp"
) {
goto
invalid
unless
is_regexp(
$data
);
}
elsif
(
$schema
->{type} eq
"list"
) {
goto
invalid
unless
$reftype
eq
"ARRAY"
;
@errors
= _validate_list(
$valid
,
$schema
,
$data
);
}
elsif
(
$schema
->{type} =~ /^list\((.+)\)$/) {
goto
invalid
unless
$reftype
eq
"ARRAY"
;
%tmpschema
= %{
$schema
};
$tmpschema
{subtype} = {
type
=> $1 };
@errors
= _validate_list(
$valid
, \
%tmpschema
,
$data
);
}
elsif
(
$schema
->{type} eq
"table"
) {
goto
invalid
unless
$reftype
eq
"HASH"
;
@errors
= _validate_table(
$valid
,
$schema
,
$data
);
}
elsif
(
$schema
->{type} =~ /^table\((.+)\)$/) {
goto
invalid
unless
$reftype
eq
"HASH"
;
%tmpschema
= %{
$schema
};
$tmpschema
{subtype} = {
type
=> $1 };
@errors
= _validate_table(
$valid
, \
%tmpschema
,
$data
);
}
elsif
(
$schema
->{type} eq
"struct"
) {
goto
invalid
unless
$reftype
eq
"HASH"
;
@errors
= _validate_struct(
$valid
,
$schema
,
$data
);
}
elsif
(
$schema
->{type} =~ /^
ref
\((.+)\)$/) {
goto
invalid
unless
$reftype
eq $1;
}
elsif
(
$schema
->{type} =~ /^isa\((.+)\)$/) {
goto
invalid
unless
$blessed
and
$data
->isa($1);
}
else
{
return
(
sprintf
(
"unexpected type: %s"
,
$schema
->{type}));
}
return
()
unless
@errors
;
invalid:
return
(
sprintf
(
"invalid %s: %s"
,
$schema
->{type},
$data
), \
@errors
);
}
sub
_validate ($$$);
sub
_validate ($$$) {
my
(
$valid
,
$schema
,
$data
) =
@_
;
my
(
$type
,
@errors
,
$reftype
,
$blessed
,
%tmpschema
);
$type
=
$schema
->{type};
if
(
ref
(
$type
) eq
"ARRAY"
) {
return
(_validate_multiple(
$valid
,
$schema
,
$data
, @{
$type
}));
}
if
(
$type
=~ /^list\?\((.+)\)$/) {
return
(_validate_multiple(
$valid
,
$schema
,
$data
, $1,
"list($1)"
));
}
if
(
$type
=~ /^valid\((.+)\)$/) {
return
(
sprintf
(
"unexpected schema: %s"
, $1))
unless
$valid
->{$1};
return
(_validate(
$valid
,
$valid
->{$1},
$data
));
}
goto
good
if
$type
eq
"anything"
;
if
(
$type
=~ /^(
undef
|undefined)$/) {
goto
invalid
if
defined
(
$data
);
goto
good;
}
return
(
sprintf
(
"invalid %s: <undef>"
,
$type
))
unless
defined
(
$data
);
goto
good
if
$type
eq
"defined"
;
$reftype
= reftype(
$data
);
if
(
$type
=~ /^(string|boolean|number|integer)$/ or
$type
=~ /^(duration|size|hostname|ipv[46])$/) {
goto
invalid
if
defined
(
$reftype
);
@errors
= _validate_data_nonref(
$schema
,
$data
);
}
else
{
goto
invalid
unless
defined
(
$reftype
);
goto
good
if
$type
=~ /^(reference|
ref
\(\*\))$/;
@errors
= _validate_data_ref(
$valid
,
$schema
,
$data
,
$reftype
);
}
return
(
@errors
)
if
@errors
;
good:
@errors
=
$schema
->{check}->(
$valid
,
$schema
,
$data
)
if
$schema
->{check};
return
()
unless
@errors
;
invalid:
return
(
sprintf
(
"invalid %s: %s"
,
$type
,
$data
), \
@errors
);
}
sub
new : method {
my
(
$class
,
$self
,
@errors
);
$class
=
shift
(
@_
);
$self
= {};
if
(
@_
== 0) {
$self
->{schema} =
$_BuiltIn
;
}
elsif
(
@_
== 1) {
$self
->{schema}{
""
} =
$_
[0];
}
elsif
(
@_
% 2 == 0) {
$self
->{schema} = {
@_
};
}
else
{
dief(
"new(): unexpected number of arguments: %d"
,
scalar
(
@_
));
}
{
local
$_Known
=
$self
->{schema};
@errors
= _validate(
$_BuiltIn
, {
type
=>
"table(valid(schema))"
},
$self
->{schema});
}
dief(
"new(): invalid schema: %s"
, _errfmt(
@errors
))
if
@errors
;
bless
(
$self
,
$class
);
return
(
$self
);
}
sub
options : method {
my
(
$self
,
$schema
);
$self
=
shift
(
@_
);
if
(
@_
== 0) {
dief(
"options(): no default schema"
)
unless
$self
->{schema}{
""
};
$schema
=
$self
->{schema}{
""
};
}
elsif
(
@_
== 1) {
$schema
=
shift
(
@_
);
dief(
"options(): unknown schema: %s"
,
$schema
)
unless
$self
->{schema}{
$schema
};
$schema
=
$self
->{schema}{
$schema
};
}
else
{
dief(
"options(): unexpected number of arguments: %d"
,
scalar
(
@_
));
}
return
(_options(
$self
->{schema},
$schema
,
undef
));
}
sub
validate : method {
my
(
$self
,
$data
,
$schema
,
@errors
);
$self
=
shift
(
@_
);
if
(
@_
== 1) {
$data
=
shift
(
@_
);
dief(
"validate(): no default schema"
)
unless
$self
->{schema}{
""
};
$schema
=
$self
->{schema}{
""
};
}
elsif
(
@_
== 2) {
$data
=
shift
(
@_
);
$schema
=
shift
(
@_
);
dief(
"validate(): unknown schema: %s"
,
$schema
)
unless
$self
->{schema}{
$schema
};
$schema
=
$self
->{schema}{
$schema
};
}
else
{
dief(
"validate(): unexpected number of arguments: %d"
,
scalar
(
@_
));
}
{
local
$_Known
=
$self
->{schema};
@errors
= _validate(
$self
->{schema},
$schema
,
$data
);
}
dief(
"validate(): %s"
, _errfmt(
@errors
))
if
@errors
;
}
sub
traverse : method {
my
(
$self
,
$callback
,
$data
,
$schema
);
$self
=
shift
(
@_
);
if
(
@_
== 2) {
$callback
=
shift
(
@_
);
$data
=
shift
(
@_
);
dief(
"traverse(): no default schema"
)
unless
$self
->{schema}{
""
};
$schema
=
$self
->{schema}{
""
};
}
elsif
(
@_
== 3) {
$callback
=
shift
(
@_
);
$data
=
shift
(
@_
);
$schema
=
shift
(
@_
);
dief(
"traverse(): unknown schema: %s"
,
$schema
)
unless
$self
->{schema}{
$schema
};
$schema
=
$self
->{schema}{
$schema
};
}
else
{
dief(
"traverse(): unexpected number of arguments: %d"
,
scalar
(
@_
));
}
_traverse(
$callback
,
$self
->{schema},
$schema
,
undef
,
$data
);
}
sub
import
: method {
my
(
$pkg
,
%exported
);
$pkg
=
shift
(
@_
);
foreach
my
$name
(
qw(string2hash hash2string treeify treeval
expand_duration expand_size
is_true is_false is_regexp listof
mutex reqall reqany)
) {
$exported
{
$name
}++;
}
export_control(
scalar
(
caller
()),
$pkg
, \
%exported
,
@_
);
}
1;