1 package PVE
::JSONSchema
;
5 use Storable
; # for dclone
9 use Devel
::Cycle
-quiet
; # todo: remove?
10 use PVE
::Tools
qw(split_list $IPV6RE $IPV4RE);
11 use PVE
::Exception
qw(raise);
12 use HTTP
::Status
qw(:constants);
13 use Net
::IP
qw(:PROC);
21 register_standard_option
24 our $CONFIGID_RE = qr/[a-z][a-z0-9_-]+/i;
26 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
27 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
28 # see: http://json-schema.org/
30 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
32 my $standard_options = {};
33 sub register_standard_option
{
34 my ($name, $schema) = @_;
36 die "standard option '$name' already registered\n"
37 if $standard_options->{$name};
39 $standard_options->{$name} = $schema;
42 sub get_standard_option
{
43 my ($name, $base) = @_;
45 my $std = $standard_options->{$name};
46 die "no such standard option '$name'\n" if !$std;
48 my $res = $base || {};
50 foreach my $opt (keys %$std) {
51 next if defined($res->{$opt});
52 $res->{$opt} = $std->{$opt};
58 register_standard_option
('pve-vmid', {
59 description
=> "The (unique) ID of the VM.",
60 type
=> 'integer', format
=> 'pve-vmid',
64 register_standard_option
('pve-node', {
65 description
=> "The cluster node name.",
66 type
=> 'string', format
=> 'pve-node',
69 register_standard_option
('pve-node-list', {
70 description
=> "List of cluster node names.",
71 type
=> 'string', format
=> 'pve-node-list',
74 register_standard_option
('pve-iface', {
75 description
=> "Network interface name.",
76 type
=> 'string', format
=> 'pve-iface',
77 minLength
=> 2, maxLength
=> 20,
80 register_standard_option
('pve-storage-id', {
81 description
=> "The storage identifier.",
82 type
=> 'string', format
=> 'pve-storage-id',
85 register_standard_option
('pve-config-digest', {
86 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
89 maxLength
=> 40, # sha1 hex digest length is 40
92 register_standard_option
('skiplock', {
93 description
=> "Ignore locks - only root is allowed to use this option.",
98 register_standard_option
('extra-args', {
99 description
=> "Extra arguments as array",
101 items
=> { type
=> 'string' },
105 register_standard_option
('fingerprint-sha256', {
106 description
=> "Certificate SHA 256 fingerprint.",
108 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
111 register_standard_option
('pve-output-format', {
113 description
=> 'Output format.',
114 enum
=> [ 'text', 'json', 'json-pretty', 'yaml' ],
119 register_standard_option
('pve-snapshot-name', {
120 description
=> "The name of the snapshot.",
121 type
=> 'string', format
=> 'pve-configid',
125 my $format_list = {};
126 my $format_validators = {};
128 sub register_format
{
129 my ($name, $format, $validator) = @_;
131 die "JSON schema format '$name' already registered\n"
132 if $format_list->{$name};
135 die "A \$validator function can only be specified for hash-based formats\n"
136 if ref($format) ne 'HASH';
137 $format_validators->{$name} = $validator;
140 $format_list->{$name} = $format;
145 return $format_list->{$name};
148 my $renderer_hash = {};
150 sub register_renderer
{
151 my ($name, $code) = @_;
153 die "renderer '$name' already registered\n"
154 if $renderer_hash->{$name};
156 $renderer_hash->{$name} = $code;
161 return $renderer_hash->{$name};
164 # register some common type for pve
166 register_format
('string', sub {}); # allow format => 'string-list'
168 register_format
('urlencoded', \
&pve_verify_urlencoded
);
169 sub pve_verify_urlencoded
{
170 my ($text, $noerr) = @_;
171 if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
172 return undef if $noerr;
173 die "invalid urlencoded string: $text\n";
178 register_format
('pve-configid', \
&pve_verify_configid
);
179 sub pve_verify_configid
{
180 my ($id, $noerr) = @_;
182 if ($id !~ m/^$CONFIGID_RE$/) {
183 return undef if $noerr;
184 die "invalid configuration ID '$id'\n";
189 PVE
::JSONSchema
::register_format
('pve-storage-id', \
&parse_storage_id
);
190 sub parse_storage_id
{
191 my ($storeid, $noerr) = @_;
193 return parse_id
($storeid, 'storage', $noerr);
196 PVE
::JSONSchema
::register_format
('acme-plugin-id', \
&parse_acme_plugin_id
);
197 sub parse_acme_plugin_id
{
198 my ($pluginid, $noerr) = @_;
200 return parse_id
($pluginid, 'ACME plugin', $noerr);
204 my ($id, $type, $noerr) = @_;
206 if ($id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
207 return undef if $noerr;
208 die "$type ID '$id' contains illegal characters\n";
213 register_format
('pve-vmid', \
&pve_verify_vmid
);
214 sub pve_verify_vmid
{
215 my ($vmid, $noerr) = @_;
217 if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
218 return undef if $noerr;
219 die "value does not look like a valid VM ID\n";
224 register_format
('pve-node', \
&pve_verify_node_name
);
225 sub pve_verify_node_name
{
226 my ($node, $noerr) = @_;
228 if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
229 return undef if $noerr;
230 die "value does not look like a valid node name\n";
236 my ($idmap, $idformat) = @_;
238 return undef if !$idmap;
242 foreach my $entry (PVE
::Tools
::split_list
($idmap)) {
244 $map->{identity
} = 1;
245 } elsif ($entry =~ m/^([^:]+):([^:]+)$/) {
246 my ($source, $target) = ($1, $2);
248 check_format
($idformat, $source, '');
249 check_format
($idformat, $target, '');
251 die "entry '$entry' contains invalid ID - $@\n" if $@;
253 die "duplicate mapping for source '$source'\n"
254 if exists $map->{entries
}->{$source};
256 $map->{entries
}->{$source} = $target;
259 check_format
($idformat, $entry);
261 die "entry '$entry' contains invalid ID - $@\n" if $@;
263 die "default target ID can only be provided once\n"
264 if exists $map->{default};
266 $map->{default} = $entry;
270 die "identity mapping cannot be combined with other mappings\n"
271 if $map->{identity
} && ($map->{default} || exists $map->{entries
});
276 my $verify_idpair = sub {
277 my ($input, $noerr, $format) = @_;
279 eval { parse_idmap
($input, $format) };
281 return undef if $noerr;
288 # note: this only checks a single list entry
289 # when using a storagepair-list map, you need to pass the full parameter to
291 register_format
('storagepair', \
&verify_storagepair
);
292 sub verify_storagepair
{
293 my ($storagepair, $noerr) = @_;
294 return $verify_idpair->($storagepair, $noerr, 'pve-storage-id');
297 register_format
('mac-addr', \
&pve_verify_mac_addr
);
298 sub pve_verify_mac_addr
{
299 my ($mac_addr, $noerr) = @_;
301 # don't allow I/G bit to be set, most of the time it breaks things, see:
302 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
303 if ($mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i) {
304 return undef if $noerr;
305 die "value does not look like a valid unicast MAC address\n";
310 register_standard_option
('mac-addr', {
312 description
=> 'Unicast MAC address.',
313 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.',
314 format_description
=> "XX:XX:XX:XX:XX:XX",
316 format
=> 'mac-addr',
319 register_format
('ipv4', \
&pve_verify_ipv4
);
320 sub pve_verify_ipv4
{
321 my ($ipv4, $noerr) = @_;
323 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
324 return undef if $noerr;
325 die "value does not look like a valid IPv4 address\n";
330 register_format
('ipv6', \
&pve_verify_ipv6
);
331 sub pve_verify_ipv6
{
332 my ($ipv6, $noerr) = @_;
334 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
335 return undef if $noerr;
336 die "value does not look like a valid IPv6 address\n";
341 register_format
('ip', \
&pve_verify_ip
);
343 my ($ip, $noerr) = @_;
345 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
346 return undef if $noerr;
347 die "value does not look like a valid IP address\n";
352 PVE
::JSONSchema
::register_format
('ldap-simple-attr', \
&verify_ldap_simple_attr
);
353 sub verify_ldap_simple_attr
{
354 my ($attr, $noerr) = @_;
356 if ($attr =~ m/^[a-zA-Z0-9]+$/) {
360 die "value '$attr' does not look like a simple ldap attribute name\n" if !$noerr;
365 my $ipv4_mask_hash = {
383 '255.255.128.0' => 17,
384 '255.255.192.0' => 18,
385 '255.255.224.0' => 19,
386 '255.255.240.0' => 20,
387 '255.255.248.0' => 21,
388 '255.255.252.0' => 22,
389 '255.255.254.0' => 23,
390 '255.255.255.0' => 24,
391 '255.255.255.128' => 25,
392 '255.255.255.192' => 26,
393 '255.255.255.224' => 27,
394 '255.255.255.240' => 28,
395 '255.255.255.248' => 29,
396 '255.255.255.252' => 30,
397 '255.255.255.254' => 31,
398 '255.255.255.255' => 32,
401 sub get_netmask_bits
{
403 return $ipv4_mask_hash->{$mask};
406 register_format
('ipv4mask', \
&pve_verify_ipv4mask
);
407 sub pve_verify_ipv4mask
{
408 my ($mask, $noerr) = @_;
410 if (!defined($ipv4_mask_hash->{$mask})) {
411 return undef if $noerr;
412 die "value does not look like a valid IP netmask\n";
417 register_format
('CIDRv6', \
&pve_verify_cidrv6
);
418 sub pve_verify_cidrv6
{
419 my ($cidr, $noerr) = @_;
421 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
425 return undef if $noerr;
426 die "value does not look like a valid IPv6 CIDR network\n";
429 register_format
('CIDRv4', \
&pve_verify_cidrv4
);
430 sub pve_verify_cidrv4
{
431 my ($cidr, $noerr) = @_;
433 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
437 return undef if $noerr;
438 die "value does not look like a valid IPv4 CIDR network\n";
441 register_format
('CIDR', \
&pve_verify_cidr
);
442 sub pve_verify_cidr
{
443 my ($cidr, $noerr) = @_;
445 if (!(pve_verify_cidrv4
($cidr, 1) ||
446 pve_verify_cidrv6
($cidr, 1)))
448 return undef if $noerr;
449 die "value does not look like a valid CIDR network\n";
455 register_format
('pve-ipv4-config', \
&pve_verify_ipv4_config
);
456 sub pve_verify_ipv4_config
{
457 my ($config, $noerr) = @_;
459 return $config if $config =~ /^(?:dhcp|manual)$/ ||
460 pve_verify_cidrv4
($config, 1);
461 return undef if $noerr;
462 die "value does not look like a valid ipv4 network configuration\n";
465 register_format
('pve-ipv6-config', \
&pve_verify_ipv6_config
);
466 sub pve_verify_ipv6_config
{
467 my ($config, $noerr) = @_;
469 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
470 pve_verify_cidrv6
($config, 1);
471 return undef if $noerr;
472 die "value does not look like a valid ipv6 network configuration\n";
475 register_format
('email', \
&pve_verify_email
);
476 sub pve_verify_email
{
477 my ($email, $noerr) = @_;
479 if ($email !~ /^$PVE::Tools::EMAIL_RE$/) {
480 return undef if $noerr;
481 die "value does not look like a valid email address\n";
486 register_format
('email-or-username', \
&pve_verify_email_or_username
);
487 sub pve_verify_email_or_username
{
488 my ($email, $noerr) = @_;
490 if ($email !~ /^$PVE::Tools::EMAIL_RE$/ &&
491 $email !~ /^$PVE::Tools::EMAIL_USER_RE$/) {
492 return undef if $noerr;
493 die "value does not look like a valid email address or user name\n";
498 register_format
('dns-name', \
&pve_verify_dns_name
);
499 sub pve_verify_dns_name
{
500 my ($name, $noerr) = @_;
502 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
504 if ($name !~ /^(${namere}\.)*${namere}$/) {
505 return undef if $noerr;
506 die "value does not look like a valid DNS name\n";
511 register_format
('timezone', \
&pve_verify_timezone
);
512 sub pve_verify_timezone
{
513 my ($timezone, $noerr) = @_;
515 return $timezone if $timezone eq 'UTC';
517 open(my $fh, "<", "/usr/share/zoneinfo/zone.tab");
518 while (my $line = <$fh>) {
519 next if $line =~ /^\s*#/;
521 my $zone = (split /\t/, $line)[2];
522 return $timezone if $timezone eq $zone; # found
526 return undef if $noerr;
527 die "invalid time zone '$timezone'\n";
530 # network interface name
531 register_format
('pve-iface', \
&pve_verify_iface
);
532 sub pve_verify_iface
{
533 my ($id, $noerr) = @_;
535 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
536 return undef if $noerr;
537 die "invalid network interface name '$id'\n";
542 # general addresses by name or IP
543 register_format
('address', \
&pve_verify_address
);
544 sub pve_verify_address
{
545 my ($addr, $noerr) = @_;
547 if (!(pve_verify_ip
($addr, 1) ||
548 pve_verify_dns_name
($addr, 1)))
550 return undef if $noerr;
551 die "value does not look like a valid address: $addr\n";
556 register_format
('disk-size', \
&pve_verify_disk_size
);
557 sub pve_verify_disk_size
{
558 my ($size, $noerr) = @_;
559 if (!defined(parse_size
($size))) {
560 return undef if $noerr;
561 die "value does not look like a valid disk size: $size\n";
566 register_standard_option
('spice-proxy', {
567 description
=> "SPICE proxy server. This can be used by the client to specify the proxy server. All nodes in a cluster runs 'spiceproxy', so it is up to the client to choose one. By default, we return the node where the VM is currently running. As reasonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).",
568 type
=> 'string', format
=> 'address',
571 register_standard_option
('remote-viewer-config', {
572 description
=> "Returned values can be directly passed to the 'remote-viewer' application.",
573 additionalProperties
=> 1,
575 type
=> { type
=> 'string' },
576 password
=> { type
=> 'string' },
577 proxy
=> { type
=> 'string' },
578 host
=> { type
=> 'string' },
579 'tls-port' => { type
=> 'integer' },
583 register_format
('pve-startup-order', \
&pve_verify_startup_order
);
584 sub pve_verify_startup_order
{
585 my ($value, $noerr) = @_;
587 return $value if pve_parse_startup_order
($value);
589 return undef if $noerr;
591 die "unable to parse startup options\n";
596 type
=> 'number', minimum
=> '0',
597 format_description
=> 'LIMIT',
600 my $bwlimit_format = {
603 description
=> 'default bandwidth limit in KiB/s',
607 description
=> 'bandwidth limit in KiB/s for restoring guests from backups',
611 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)',
615 description
=> 'bandwidth limit in KiB/s for cloning disks',
619 description
=> 'bandwidth limit in KiB/s for moving disks',
622 register_format
('bwlimit', $bwlimit_format);
623 register_standard_option
('bwlimit', {
624 description
=> "Set bandwidth/io limits various operations.",
627 format
=> $bwlimit_format,
630 # used for pve-tag-list in e.g., guest configs
631 register_format
('pve-tag', \
&pve_verify_tag
);
633 my ($value, $noerr) = @_;
635 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i;
637 return undef if $noerr;
639 die "invalid characters in tag\n";
642 sub pve_parse_startup_order
{
645 return undef if !$value;
649 foreach my $p (split(/,/, $value)) {
650 next if $p =~ m/^\s*$/;
652 if ($p =~ m/^(order=)?(\d+)$/) {
654 } elsif ($p =~ m/^up=(\d+)$/) {
656 } elsif ($p =~ m/^down=(\d+)$/) {
666 PVE
::JSONSchema
::register_standard_option
('pve-startup-order', {
667 description
=> "Startup and shutdown behavior. Order is a non-negative number defining the general startup order. Shutdown in done with reverse ordering. Additionally you can set the 'up' or 'down' delay in seconds, which specifies a delay to wait before the next VM is started or stopped.",
669 type
=> 'string', format
=> 'pve-startup-order',
670 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ',
673 register_format
('pve-tfa-secret', \
&pve_verify_tfa_secret
);
674 sub pve_verify_tfa_secret
{
675 my ($key, $noerr) = @_;
677 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
678 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
679 # format to support arbitrary lengths properly:
680 if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
681 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
682 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
687 return undef if $noerr;
689 die "unable to decode TFA secret\n";
693 my ($format, $value, $path) = @_;
695 if (ref($format) eq 'HASH') {
696 # hash ref cannot have validator/list/opt handling attached
697 return parse_property_string
($format, $value, $path);
700 if (ref($format) eq 'CODE') {
701 # we are the (sole, old-style) validator
702 return $format->($value);
705 return if $format eq 'regex';
708 $format =~ m/^(.*?)(?:-a?(list|opt))?$/;
709 my ($format_name, $format_type) = ($1, $2 // 'none');
710 my $registered = get_format
($format_name);
711 die "undefined format '$format'\n" if !$registered;
713 die "'-$format_type' format must have code ref, not hash\n"
714 if $format_type ne 'none' && ref($registered) ne 'CODE';
716 if ($format_type eq 'list') {
718 # Note: we allow empty lists
719 foreach my $v (split_list
($value)) {
720 push @{$parsed}, $registered->($v);
722 } elsif ($format_type eq 'opt') {
723 $parsed = $registered->($value) if $value;
725 if (ref($registered) eq 'HASH') {
726 # Note: this is the only case where a validator function could be
727 # attached, hence it's safe to handle that in parse_property_string.
728 # We do however have to call it with $format_name instead of
729 # $registered, so it knows about the name (and thus any validators).
730 $parsed = parse_property_string
($format, $value, $path);
732 $parsed = $registered->($value);
742 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
743 my ($size, $unit) = ($1, $3);
746 $size = $size * 1024;
747 } elsif ($unit eq 'M') {
748 $size = $size * 1024 * 1024;
749 } elsif ($unit eq 'G') {
750 $size = $size * 1024 * 1024 * 1024;
751 } elsif ($unit eq 'T') {
752 $size = $size * 1024 * 1024 * 1024 * 1024;
763 my $kb = int($size/1024);
764 return $size if $kb*1024 != $size;
766 my $mb = int($kb/1024);
767 return "${kb}K" if $mb*1024 != $kb;
769 my $gb = int($mb/1024);
770 return "${mb}M" if $gb*1024 != $mb;
772 my $tb = int($gb/1024);
773 return "${gb}G" if $tb*1024 != $gb;
780 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
781 return 0 if $bool =~ m/^(0|off|no|false)$/i;
785 sub parse_property_string
{
786 my ($format, $data, $path, $additional_properties) = @_;
788 # In property strings we default to not allowing additional properties
789 $additional_properties = 0 if !defined($additional_properties);
791 # Support named formats here, too:
794 if (my $reg = get_format
($format)) {
795 die "parse_property_string only accepts hash based named formats\n"
796 if ref($reg) ne 'HASH';
798 # named formats can have validators attached
799 $validator = $format_validators->{$format};
803 die "unknown format: $format\n";
805 } elsif (ref($format) ne 'HASH') {
806 die "unexpected format value of type ".ref($format)."\n";
812 foreach my $part (split(/,/, $data)) {
813 next if $part =~ /^\s*$/;
815 if ($part =~ /^([^=]+)=(.+)$/) {
816 my ($k, $v) = ($1, $2);
817 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
818 my $schema = $format->{$k};
819 if (my $alias = $schema->{alias
}) {
820 if (my $key_alias = $schema->{keyAlias
}) {
821 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
822 $res->{$key_alias} = $k;
825 $schema = $format->{$k};
828 die "invalid key in comma-separated list property: $k\n" if !$schema;
829 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
830 $v = parse_boolean
($v) // $v;
833 } elsif ($part !~ /=/) {
834 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
835 foreach my $key (keys %$format) {
836 if ($format->{$key}->{default_key
}) {
838 if (!$res->{$default_key}) {
839 $res->{$default_key} = $part;
842 die "duplicate key in comma-separated list property: $default_key\n";
845 die "value without key, but schema does not define a default key\n" if !$default_key;
847 die "missing key in comma-separated list property\n";
852 check_object
($path, $format, $res, $additional_properties, $errors);
853 if (scalar(%$errors)) {
854 raise
"format error\n", errors
=> $errors;
857 return $validator->($res) if $validator;
862 my ($errors, $path, $msg) = @_;
864 $path = '_root' if !$path;
866 if ($errors->{$path}) {
867 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
869 $errors->{$path} = $msg;
876 # see 'man perlretut'
877 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
883 return $value =~ m/^[+-]?\d+$/;
887 my ($path, $type, $value, $errors) = @_;
891 if (!defined($value)) {
892 return 1 if $type eq 'null';
896 if (my $tt = ref($type)) {
897 if ($tt eq 'ARRAY') {
898 foreach my $t (@$type) {
900 check_type
($path, $t, $value, $tmperr);
901 return 1 if !scalar(%$tmperr);
903 my $ttext = join ('|', @$type);
904 add_error
($errors, $path, "type check ('$ttext') failed");
906 } elsif ($tt eq 'HASH') {
908 check_prop
($value, $type, $path, $tmperr);
909 return 1 if !scalar(%$tmperr);
910 add_error
($errors, $path, "type check failed");
913 die "internal error - got reference type '$tt'";
918 return 1 if $type eq 'any';
920 if ($type eq 'null') {
921 if (defined($value)) {
922 add_error
($errors, $path, "type check ('$type') failed - value is not null");
928 my $vt = ref($value);
930 if ($type eq 'array') {
931 if (!$vt || $vt ne 'ARRAY') {
932 add_error
($errors, $path, "type check ('$type') failed");
936 } elsif ($type eq 'object') {
937 if (!$vt || $vt ne 'HASH') {
938 add_error
($errors, $path, "type check ('$type') failed");
942 } elsif ($type eq 'coderef') {
943 if (!$vt || $vt ne 'CODE') {
944 add_error
($errors, $path, "type check ('$type') failed");
948 } elsif ($type eq 'string' && $vt eq 'Regexp') {
949 # qr// regexes can be used as strings and make sense for format=regex
953 add_error
($errors, $path, "type check ('$type') failed - got $vt");
956 if ($type eq 'string') {
957 return 1; # nothing to check ?
958 } elsif ($type eq 'boolean') {
959 #if ($value =~ m/^(1|true|yes|on)$/i) {
962 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
963 } elsif ($value eq '0') {
964 return 1; # return success (not value)
966 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
969 } elsif ($type eq 'integer') {
970 if (!is_integer
($value)) {
971 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
975 } elsif ($type eq 'number') {
976 if (!is_number
($value)) {
977 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
982 return 1; # no need to verify unknown types
992 my ($path, $schema, $value, $additional_properties, $errors) = @_;
994 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
996 my $st = ref($schema);
997 if (!$st || $st ne 'HASH') {
998 add_error
($errors, $path, "Invalid schema definition.");
1002 my $vt = ref($value);
1003 if (!$vt || $vt ne 'HASH') {
1004 add_error
($errors, $path, "an object is required");
1008 foreach my $k (keys %$schema) {
1009 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
1012 foreach my $k (keys %$value) {
1014 my $newpath = $path ?
"$path.$k" : $k;
1016 if (my $subschema = $schema->{$k}) {
1017 if (my $requires = $subschema->{requires
}) {
1018 if (ref($requires)) {
1019 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1020 check_prop
($value, $requires, $path, $errors);
1021 } elsif (!defined($value->{$requires})) {
1022 add_error
($errors, $path ?
"$path.$requires" : $requires,
1023 "missing property - '$newpath' requires this property");
1027 next; # value is already checked above
1030 if (defined ($additional_properties) && !$additional_properties) {
1031 add_error
($errors, $newpath, "property is not defined in schema " .
1032 "and the schema does not allow additional properties");
1035 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
1036 if ref($additional_properties);
1040 sub check_object_warn
{
1041 my ($path, $schema, $value, $additional_properties) = @_;
1043 check_object
($path, $schema, $value, $additional_properties, $errors);
1044 if (scalar(%$errors)) {
1045 foreach my $k (keys %$errors) {
1046 warn "parse error: $k: $errors->{$k}\n";
1054 my ($value, $schema, $path, $errors) = @_;
1056 die "internal error - no schema" if !$schema;
1057 die "internal error" if !$errors;
1059 #print "check_prop $path\n" if $value;
1061 my $st = ref($schema);
1062 if (!$st || $st ne 'HASH') {
1063 add_error
($errors, $path, "Invalid schema definition.");
1067 # if it extends another schema, it must pass that schema as well
1068 if($schema->{extends
}) {
1069 check_prop
($value, $schema->{extends
}, $path, $errors);
1072 if (!defined ($value)) {
1073 return if $schema->{type
} && $schema->{type
} eq 'null';
1074 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
1075 add_error
($errors, $path, "property is missing and it is not optional");
1080 return if !check_type
($path, $schema->{type
}, $value, $errors);
1082 if ($schema->{disallow
}) {
1084 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
1085 add_error
($errors, $path, "disallowed value was matched");
1090 if (my $vt = ref($value)) {
1092 if ($vt eq 'ARRAY') {
1093 if ($schema->{items
}) {
1094 my $it = ref($schema->{items
});
1095 if ($it && $it eq 'ARRAY') {
1096 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1097 die "not implemented";
1100 foreach my $el (@$value) {
1101 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
1107 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
1108 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
1109 $value, $schema->{additionalProperties
}, $errors);
1115 if (my $format = $schema->{format
}) {
1116 eval { check_format
($format, $value, $path); };
1118 add_error
($errors, $path, "invalid format - $@");
1123 if (my $pattern = $schema->{pattern
}) {
1124 if ($value !~ m/^$pattern$/) {
1125 add_error
($errors, $path, "value does not match the regex pattern");
1130 if (defined (my $max = $schema->{maxLength
})) {
1131 if (length($value) > $max) {
1132 add_error
($errors, $path, "value may only be $max characters long");
1137 if (defined (my $min = $schema->{minLength
})) {
1138 if (length($value) < $min) {
1139 add_error
($errors, $path, "value must be at least $min characters long");
1144 if (is_number
($value)) {
1145 if (defined (my $max = $schema->{maximum
})) {
1146 if ($value > $max) {
1147 add_error
($errors, $path, "value must have a maximum value of $max");
1152 if (defined (my $min = $schema->{minimum
})) {
1153 if ($value < $min) {
1154 add_error
($errors, $path, "value must have a minimum value of $min");
1160 if (my $ea = $schema->{enum
}) {
1163 foreach my $ev (@$ea) {
1164 if ($ev eq $value) {
1170 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
1171 join(", ", @$ea) . "'");
1178 my ($instance, $schema, $errmsg) = @_;
1181 $errmsg = "Parameter verification failed.\n" if !$errmsg;
1183 # todo: cycle detection is only needed for debugging, I guess
1184 # we can disable that in the final release
1185 # todo: is there a better/faster way to detect cycles?
1187 # 'download' responses can contain a filehandle, don't cycle-check that as
1188 # it produces a warning
1189 my $is_download = ref($instance) eq 'HASH' && exists($instance->{download
});
1190 find_cycle
($instance, sub { $cycles = 1 }) if !$is_download;
1192 add_error
($errors, undef, "data structure contains recursive cycles");
1194 check_prop
($instance, $schema, '', $errors);
1197 if (scalar(%$errors)) {
1198 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1204 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1205 my $default_schema_noref = {
1206 description
=> "This is the JSON Schema for JSON Schemas.",
1207 type
=> [ "object" ],
1208 additionalProperties
=> 0,
1211 type
=> ["string", "array"],
1212 description
=> "This is a type definition value. This can be a simple type, or a union type",
1217 enum
=> $schema_valid_types,
1219 enum
=> $schema_valid_types,
1223 description
=> "This indicates that the instance property in the instance object is not required.",
1229 description
=> "This is a definition for the properties of an object value",
1235 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1239 additionalProperties
=> {
1240 type
=> [ "boolean", "object"],
1241 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1248 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1253 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1257 description
=> "When the instance value is a string, this indicates minimum length of the string",
1264 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1270 description
=> "A text representation of the type (used to generate documentation).",
1275 description
=> "When the instance value is a string, this provides a regular expression that a instance string value should match in order to be valid.",
1282 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1287 description
=> "This provides a description of the purpose the instance property. The value can be a string or it can be an object with properties corresponding to various different instance languages (with an optional default property indicating the default description).",
1289 verbose_description
=> {
1292 description
=> "This provides a more verbose description.",
1294 format_description
=> {
1297 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1302 description
=> "This provides the title of the property",
1307 description
=> "This is used to provide rendering hints to format cli command output.",
1310 type
=> [ "string", "object" ],
1312 description
=> "indicates a required property or a schema that must be validated if this property is present",
1315 type
=> [ "string", "object" ],
1317 description
=> "This indicates what format the data is among some predefined formats which may include:\n\ndate - a string following the ISO format \naddress \nschema - a schema definition object \nperson \npage \nhtml - a string representing HTML",
1322 description
=> "Whether this is the default key in a comma separated list property string.",
1327 description
=> "When a key represents the same property as another it can be an alias to it, causing the parsed datastructure to use the other key to store the current value under.",
1332 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1333 requires
=> 'alias',
1338 description
=> "This indicates the default for the instance property."
1342 description
=> "Bash completion function. This function should return a list of possible values.",
1348 description
=> "This attribute may take the same values as the \"type\" attribute, however if the instance matches the type or if this value is an array and the instance matches any type or schema in the array, then this instance is not valid.",
1353 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1356 # this is from hyper schema
1359 description
=> "This defines the link relations of the instance objects",
1366 description
=> "This defines the target URL for the relation and can be parameterized using {propertyName} notation. It should be resolved as a URI-reference relative to the URI that was used to retrieve the instance document",
1370 description
=> "This is the name of the link relation",
1376 description
=> "For submission links, this defines the method that should be used to access the target resource",
1385 description
=> "For CLI context, this defines the maximal width to print before truncating",
1391 my $default_schema = Storable
::dclone
($default_schema_noref);
1393 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1394 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1396 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1397 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1399 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1400 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1402 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1403 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1405 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1406 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1408 my $method_schema = {
1410 additionalProperties
=> 0,
1413 description
=> "This a description of the method",
1418 description
=> "This indicates the name of the function to call.",
1421 additionalProperties
=> 1,
1436 description
=> "The HTTP method name.",
1437 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1442 description
=> "Method needs special privileges - only pvedaemon can execute it",
1447 description
=> "Method is available for clients authenticated using an API token.",
1453 description
=> "Method downloads the file content (filename is the return value of the method).",
1458 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1461 proxyto_callback
=> {
1463 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1468 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1470 additionalProperties
=> 0,
1473 description
=> "Describe access permissions.",
1477 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1479 enum
=> ['all', 'world'],
1483 description
=> "Array of permission checks (prefix notation).",
1490 description
=> "Used internally",
1494 description
=> "Used internally",
1499 description
=> "path for URL matching (uri template)",
1501 fragmentDelimiter
=> {
1503 description
=> "A way to override the default fragment delimiter '/'. This only works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.",
1508 description
=> "JSON Schema for parameters.",
1513 description
=> "JSON Schema for return value.",
1518 description
=> "method implementation (code reference)",
1523 description
=> "Delegate call to this class (perl class string).",
1526 additionalProperties
=> 0,
1532 fragmentDelimiter
=> { optional
=> 1 }
1540 sub validate_schema
{
1543 my $errmsg = "internal error - unable to verify schema\n";
1544 validate
($schema, $default_schema, $errmsg);
1547 sub validate_method_info
{
1550 my $errmsg = "internal error - unable to verify method info\n";
1551 validate
($info, $method_schema, $errmsg);
1553 validate_schema
($info->{parameters
}) if $info->{parameters
};
1554 validate_schema
($info->{returns
}) if $info->{returns
};
1557 # run a self test on load
1558 # make sure we can verify the default schema
1559 validate_schema
($default_schema_noref);
1560 validate_schema
($method_schema);
1562 # and now some utility methods (used by pve api)
1563 sub method_get_child_link
{
1566 return undef if !$info;
1568 my $schema = $info->{returns
};
1569 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1571 my $links = $schema->{links
};
1572 return undef if !$links;
1575 foreach my $lnk (@$links) {
1576 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1585 # a way to parse command line parameters, using a
1586 # schema to configure Getopt::Long
1588 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1590 if (!$schema || !$schema->{properties
}) {
1591 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1592 if scalar(@$args) != 0;
1597 if ($arg_param && !ref($arg_param)) {
1598 my $pd = $schema->{properties
}->{$arg_param};
1599 die "expected list format $pd->{format}"
1600 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1601 $list_param = $arg_param;
1604 my @interactive = ();
1606 foreach my $prop (keys %{$schema->{properties
}}) {
1607 my $pd = $schema->{properties
}->{$prop};
1608 next if $list_param && $prop eq $list_param;
1609 next if defined($fixed_param->{$prop});
1611 my $mapping = $param_mapping_hash->{$prop};
1612 if ($mapping && $mapping->{interactive
}) {
1613 # interactive parameters such as passwords: make the argument
1614 # optional and call the mapping function afterwards.
1615 push @getopt, "$prop:s";
1616 push @interactive, [$prop, $mapping->{func
}];
1617 } elsif ($pd->{type
} eq 'boolean') {
1618 push @getopt, "$prop:s";
1620 if ($pd->{format
} && $pd->{format
} =~ m/-a?list/) {
1621 push @getopt, "$prop=s@";
1623 push @getopt, "$prop=s";
1628 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1631 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1632 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1636 $opts->{$list_param} = $args;
1638 } elsif (ref($arg_param)) {
1639 for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1640 my $arg_name = $arg_param->[$i];
1641 if ($opts->{'extra-args'}) {
1642 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1644 if ($arg_name eq 'extra-args') {
1645 $opts->{'extra-args'} = $args;
1650 # check if all left-over arg_param are optional, else we
1651 # must die as the mapping is then ambigious
1652 for (; $i < scalar(@$arg_param); $i++) {
1653 my $prop = $arg_param->[$i];
1654 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
)
1655 if !$schema->{properties
}->{$prop}->{optional
};
1657 if ($arg_param->[-1] eq 'extra-args') {
1658 $opts->{'extra-args'} = [];
1662 $opts->{$arg_name} = shift @$args;
1664 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1666 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1667 if scalar(@$args) != 0;
1670 if (ref($arg_param)) {
1671 foreach my $arg_name (@$arg_param) {
1672 if ($arg_name eq 'extra-args') {
1673 $opts->{'extra-args'} = [];
1674 } elsif (!$schema->{properties
}->{$arg_name}->{optional
}) {
1675 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1681 foreach my $entry (@interactive) {
1682 my ($opt, $func) = @$entry;
1683 my $pd = $schema->{properties
}->{$opt};
1684 my $value = $opts->{$opt};
1685 if (defined($value) || !$pd->{optional
}) {
1686 $opts->{$opt} = $func->($value);
1690 # decode after Getopt as we are not sure how well it handles unicode
1691 foreach my $p (keys %$opts) {
1692 if (!ref($opts->{$p})) {
1693 $opts->{$p} = decode
('locale', $opts->{$p});
1694 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1696 foreach my $v (@{$opts->{$p}}) {
1697 push @$tmp, decode
('locale', $v);
1700 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1701 $opts->{$p} = decode
('locale', $$opts->{$p});
1703 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1707 foreach my $p (keys %$opts) {
1708 if (my $pd = $schema->{properties
}->{$p}) {
1709 if ($pd->{type
} eq 'boolean') {
1710 if ($opts->{$p} eq '') {
1712 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1713 $opts->{$p} = $bool;
1715 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1717 } elsif ($pd->{format
}) {
1719 if ($pd->{format
} =~ m/-list/) {
1720 # allow --vmid 100 --vmid 101 and --vmid 100,101
1721 # allow --dow mon --dow fri and --dow mon,fri
1722 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1723 } elsif ($pd->{format
} =~ m/-alist/) {
1724 # we encode array as \0 separated strings
1725 # Note: CGI.pm also use this encoding
1726 if (scalar(@{$opts->{$p}}) != 1) {
1727 $opts->{$p} = join("\0", @{$opts->{$p}});
1729 # st that split_list knows it is \0 terminated
1730 my $v = $opts->{$p}->[0];
1731 $opts->{$p} = "$v\0";
1738 foreach my $p (keys %$fixed_param) {
1739 $opts->{$p} = $fixed_param->{$p};
1745 # A way to parse configuration data by giving a json schema
1747 my ($schema, $filename, $raw) = @_;
1749 # do fast check (avoid validate_schema($schema))
1750 die "got strange schema" if !$schema->{type
} ||
1751 !$schema->{properties
} || $schema->{type
} ne 'object';
1755 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1758 next if $line =~ /^#/;
1760 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1763 if ($schema->{properties
}->{$key} &&
1764 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1766 $value = parse_boolean
($value) // $value;
1768 $cfg->{$key} = $value;
1770 warn "ignore config line: $line\n"
1775 check_prop
($cfg, $schema, '', $errors);
1777 foreach my $k (keys %$errors) {
1778 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1785 # generate simple key/value file
1787 my ($schema, $filename, $cfg) = @_;
1789 # do fast check (avoid validate_schema($schema))
1790 die "got strange schema" if !$schema->{type
} ||
1791 !$schema->{properties
} || $schema->{type
} ne 'object';
1793 validate
($cfg, $schema, "validation error in '$filename'\n");
1797 foreach my $k (sort keys %$cfg) {
1798 $data .= "$k: $cfg->{$k}\n";
1804 # helpers used to generate our manual pages
1806 my $find_schema_default_key = sub {
1810 my $keyAliasProps = {};
1812 foreach my $key (keys %$format) {
1813 my $phash = $format->{$key};
1814 if ($phash->{default_key
}) {
1815 die "multiple default keys in schema ($default_key, $key)\n"
1816 if defined($default_key);
1817 die "default key '$key' is an alias - this is not allowed\n"
1818 if defined($phash->{alias
});
1819 die "default key '$key' with keyAlias attribute is not allowed\n"
1820 if $phash->{keyAlias
};
1821 $default_key = $key;
1823 my $key_alias = $phash->{keyAlias
};
1824 die "found keyAlias without 'alias definition for '$key'\n"
1825 if $key_alias && !$phash->{alias
};
1827 if ($phash->{alias
} && $key_alias) {
1828 die "inconsistent keyAlias '$key_alias' definition"
1829 if defined($keyAliasProps->{$key_alias}) &&
1830 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1831 $keyAliasProps->{$key_alias} = $phash->{alias
};
1835 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1838 sub generate_typetext
{
1839 my ($format, $list_enums) = @_;
1841 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1846 my $add_option_string = sub {
1847 my ($text, $optional) = @_;
1853 $text = "[$text]" if $optional;
1858 my $format_key_value = sub {
1859 my ($key, $phash) = @_;
1861 die "internal error" if defined($phash->{alias
});
1867 if (my $desc = $phash->{format_description
}) {
1868 $typetext .= "<$desc>";
1869 } elsif (my $text = $phash->{typetext
}) {
1871 } elsif (my $enum = $phash->{enum
}) {
1872 if ($list_enums || (scalar(@$enum) <= 3)) {
1873 $typetext .= '<' . join('|', @$enum) . '>';
1875 $typetext .= '<enum>';
1877 } elsif ($phash->{type
} eq 'boolean') {
1878 $typetext .= '<1|0>';
1879 } elsif ($phash->{type
} eq 'integer') {
1880 $typetext .= '<integer>';
1881 } elsif ($phash->{type
} eq 'number') {
1882 $typetext .= '<number>';
1884 die "internal error: neither format_description nor typetext found for option '$key'";
1887 if (defined($default_key) && ($default_key eq $key)) {
1888 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
1890 &$add_option_string("$keytext=$typetext", $phash->{optional
});
1896 my $cond_add_key = sub {
1899 return if $done->{$key}; # avoid duplicates
1903 my $phash = $format->{$key};
1905 return if !$phash; # should not happen
1907 return if $phash->{alias
};
1909 &$format_key_value($key, $phash);
1913 &$cond_add_key($default_key) if defined($default_key);
1915 # add required keys first
1916 foreach my $key (sort keys %$format) {
1917 my $phash = $format->{$key};
1918 &$cond_add_key($key) if $phash && !$phash->{optional
};
1922 foreach my $key (sort keys %$format) {
1923 &$cond_add_key($key);
1926 foreach my $keyAlias (sort keys %$keyAliasProps) {
1927 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1933 sub print_property_string
{
1934 my ($data, $format, $skip, $path) = @_;
1937 if (ref($format) ne 'HASH') {
1938 my $schema = get_format
($format);
1939 die "not a valid format: $format\n" if !$schema;
1940 # named formats can have validators attached
1941 $validator = $format_validators->{$format};
1946 check_object
($path, $format, $data, undef, $errors);
1947 if (scalar(%$errors)) {
1948 raise
"format error", errors
=> $errors;
1951 $data = $validator->($data) if $validator;
1953 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1958 my $add_option_string = sub {
1961 $res .= ',' if $add_sep;
1966 my $format_value = sub {
1967 my ($key, $value, $format) = @_;
1969 if (defined($format) && ($format eq 'disk-size')) {
1970 return format_size
($value);
1972 die "illegal value with commas for $key\n" if $value =~ /,/;
1977 my $done = { map { $_ => 1 } @$skip };
1979 my $cond_add_key = sub {
1980 my ($key, $isdefault) = @_;
1982 return if $done->{$key}; # avoid duplicates
1986 my $value = $data->{$key};
1988 return if !defined($value);
1990 my $phash = $format->{$key};
1992 # try to combine values if we have key aliases
1993 if (my $combine = $keyAliasProps->{$key}) {
1994 if (defined(my $combine_value = $data->{$combine})) {
1995 my $combine_format = $format->{$combine}->{format
};
1996 my $value_str = &$format_value($key, $value, $phash->{format
});
1997 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1998 &$add_option_string("${value_str}=${combine_str}");
1999 $done->{$combine} = 1;
2004 if ($phash && $phash->{alias
}) {
2005 $phash = $format->{$phash->{alias
}};
2008 die "invalid key '$key'\n" if !$phash;
2009 die "internal error" if defined($phash->{alias
});
2011 my $value_str = &$format_value($key, $value, $phash->{format
});
2013 &$add_option_string($value_str);
2015 &$add_option_string("$key=${value_str}");
2019 # add default key first
2020 &$cond_add_key($default_key, 1) if defined($default_key);
2022 # add required keys first
2023 foreach my $key (sort keys %$data) {
2024 my $phash = $format->{$key};
2025 &$cond_add_key($key) if $phash && !$phash->{optional
};
2029 foreach my $key (sort keys %$data) {
2030 &$cond_add_key($key);
2036 sub schema_get_type_text
{
2037 my ($phash, $style) = @_;
2039 my $type = $phash->{type
} || 'string';
2041 if ($phash->{typetext
}) {
2042 return $phash->{typetext
};
2043 } elsif ($phash->{format_description
}) {
2044 return "<$phash->{format_description}>";
2045 } elsif ($phash->{enum
}) {
2046 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
2047 } elsif ($phash->{pattern
}) {
2048 return $phash->{pattern
};
2049 } elsif ($type eq 'integer' || $type eq 'number') {
2050 # NOTE: always access values as number (avoid converion to string)
2051 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
2052 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
2053 ($phash->{maximum
} + 0) . ")";
2054 } elsif (defined($phash->{minimum
})) {
2055 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
2056 } elsif (defined($phash->{maximum
})) {
2057 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
2059 } elsif ($type eq 'string') {
2060 if (my $format = $phash->{format
}) {
2061 $format = get_format
($format) if ref($format) ne 'HASH';
2062 if (ref($format) eq 'HASH') {
2064 $list_enums = 1 if $style && $style eq 'config-sub';
2065 return generate_typetext
($format, $list_enums);