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 PVE
::JSONSchema
::register_format
('pve-task-status-type', \
&verify_task_status_type
);
694 sub verify_task_status_type
{
695 my ($value, $noerr) = @_;
697 return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
699 return undef if $noerr;
701 die "invalid status '$value'\n";
705 my ($format, $value, $path) = @_;
707 if (ref($format) eq 'HASH') {
708 # hash ref cannot have validator/list/opt handling attached
709 return parse_property_string
($format, $value, $path);
712 if (ref($format) eq 'CODE') {
713 # we are the (sole, old-style) validator
714 return $format->($value);
717 return if $format eq 'regex';
720 $format =~ m/^(.*?)(?:-a?(list|opt))?$/;
721 my ($format_name, $format_type) = ($1, $2 // 'none');
722 my $registered = get_format
($format_name);
723 die "undefined format '$format'\n" if !$registered;
725 die "'-$format_type' format must have code ref, not hash\n"
726 if $format_type ne 'none' && ref($registered) ne 'CODE';
728 if ($format_type eq 'list') {
730 # Note: we allow empty lists
731 foreach my $v (split_list
($value)) {
732 push @{$parsed}, $registered->($v);
734 } elsif ($format_type eq 'opt') {
735 $parsed = $registered->($value) if $value;
737 if (ref($registered) eq 'HASH') {
738 # Note: this is the only case where a validator function could be
739 # attached, hence it's safe to handle that in parse_property_string.
740 # We do however have to call it with $format_name instead of
741 # $registered, so it knows about the name (and thus any validators).
742 $parsed = parse_property_string
($format, $value, $path);
744 $parsed = $registered->($value);
754 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
755 my ($size, $unit) = ($1, $3);
758 $size = $size * 1024;
759 } elsif ($unit eq 'M') {
760 $size = $size * 1024 * 1024;
761 } elsif ($unit eq 'G') {
762 $size = $size * 1024 * 1024 * 1024;
763 } elsif ($unit eq 'T') {
764 $size = $size * 1024 * 1024 * 1024 * 1024;
775 my $kb = int($size/1024);
776 return $size if $kb*1024 != $size;
778 my $mb = int($kb/1024);
779 return "${kb}K" if $mb*1024 != $kb;
781 my $gb = int($mb/1024);
782 return "${mb}M" if $gb*1024 != $mb;
784 my $tb = int($gb/1024);
785 return "${gb}G" if $tb*1024 != $gb;
792 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
793 return 0 if $bool =~ m/^(0|off|no|false)$/i;
797 sub parse_property_string
{
798 my ($format, $data, $path, $additional_properties) = @_;
800 # In property strings we default to not allowing additional properties
801 $additional_properties = 0 if !defined($additional_properties);
803 # Support named formats here, too:
806 if (my $reg = get_format
($format)) {
807 die "parse_property_string only accepts hash based named formats\n"
808 if ref($reg) ne 'HASH';
810 # named formats can have validators attached
811 $validator = $format_validators->{$format};
815 die "unknown format: $format\n";
817 } elsif (ref($format) ne 'HASH') {
818 die "unexpected format value of type ".ref($format)."\n";
824 foreach my $part (split(/,/, $data)) {
825 next if $part =~ /^\s*$/;
827 if ($part =~ /^([^=]+)=(.+)$/) {
828 my ($k, $v) = ($1, $2);
829 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
830 my $schema = $format->{$k};
831 if (my $alias = $schema->{alias
}) {
832 if (my $key_alias = $schema->{keyAlias
}) {
833 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
834 $res->{$key_alias} = $k;
837 $schema = $format->{$k};
840 die "invalid key in comma-separated list property: $k\n" if !$schema;
841 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
842 $v = parse_boolean
($v) // $v;
845 } elsif ($part !~ /=/) {
846 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
847 foreach my $key (keys %$format) {
848 if ($format->{$key}->{default_key
}) {
850 if (!$res->{$default_key}) {
851 $res->{$default_key} = $part;
854 die "duplicate key in comma-separated list property: $default_key\n";
857 die "value without key, but schema does not define a default key\n" if !$default_key;
859 die "missing key in comma-separated list property\n";
864 check_object
($path, $format, $res, $additional_properties, $errors);
865 if (scalar(%$errors)) {
866 raise
"format error\n", errors
=> $errors;
869 return $validator->($res) if $validator;
874 my ($errors, $path, $msg) = @_;
876 $path = '_root' if !$path;
878 if ($errors->{$path}) {
879 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
881 $errors->{$path} = $msg;
888 # see 'man perlretut'
889 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
895 return $value =~ m/^[+-]?\d+$/;
899 my ($path, $type, $value, $errors) = @_;
903 if (!defined($value)) {
904 return 1 if $type eq 'null';
908 if (my $tt = ref($type)) {
909 if ($tt eq 'ARRAY') {
910 foreach my $t (@$type) {
912 check_type
($path, $t, $value, $tmperr);
913 return 1 if !scalar(%$tmperr);
915 my $ttext = join ('|', @$type);
916 add_error
($errors, $path, "type check ('$ttext') failed");
918 } elsif ($tt eq 'HASH') {
920 check_prop
($value, $type, $path, $tmperr);
921 return 1 if !scalar(%$tmperr);
922 add_error
($errors, $path, "type check failed");
925 die "internal error - got reference type '$tt'";
930 return 1 if $type eq 'any';
932 if ($type eq 'null') {
933 if (defined($value)) {
934 add_error
($errors, $path, "type check ('$type') failed - value is not null");
940 my $vt = ref($value);
942 if ($type eq 'array') {
943 if (!$vt || $vt ne 'ARRAY') {
944 add_error
($errors, $path, "type check ('$type') failed");
948 } elsif ($type eq 'object') {
949 if (!$vt || $vt ne 'HASH') {
950 add_error
($errors, $path, "type check ('$type') failed");
954 } elsif ($type eq 'coderef') {
955 if (!$vt || $vt ne 'CODE') {
956 add_error
($errors, $path, "type check ('$type') failed");
960 } elsif ($type eq 'string' && $vt eq 'Regexp') {
961 # qr// regexes can be used as strings and make sense for format=regex
965 add_error
($errors, $path, "type check ('$type') failed - got $vt");
968 if ($type eq 'string') {
969 return 1; # nothing to check ?
970 } elsif ($type eq 'boolean') {
971 #if ($value =~ m/^(1|true|yes|on)$/i) {
974 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
975 } elsif ($value eq '0') {
976 return 1; # return success (not value)
978 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
981 } elsif ($type eq 'integer') {
982 if (!is_integer
($value)) {
983 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
987 } elsif ($type eq 'number') {
988 if (!is_number
($value)) {
989 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
994 return 1; # no need to verify unknown types
1004 my ($path, $schema, $value, $additional_properties, $errors) = @_;
1006 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
1008 my $st = ref($schema);
1009 if (!$st || $st ne 'HASH') {
1010 add_error
($errors, $path, "Invalid schema definition.");
1014 my $vt = ref($value);
1015 if (!$vt || $vt ne 'HASH') {
1016 add_error
($errors, $path, "an object is required");
1020 foreach my $k (keys %$schema) {
1021 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
1024 foreach my $k (keys %$value) {
1026 my $newpath = $path ?
"$path.$k" : $k;
1028 if (my $subschema = $schema->{$k}) {
1029 if (my $requires = $subschema->{requires
}) {
1030 if (ref($requires)) {
1031 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1032 check_prop
($value, $requires, $path, $errors);
1033 } elsif (!defined($value->{$requires})) {
1034 add_error
($errors, $path ?
"$path.$requires" : $requires,
1035 "missing property - '$newpath' requires this property");
1039 next; # value is already checked above
1042 if (defined ($additional_properties) && !$additional_properties) {
1043 add_error
($errors, $newpath, "property is not defined in schema " .
1044 "and the schema does not allow additional properties");
1047 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
1048 if ref($additional_properties);
1052 sub check_object_warn
{
1053 my ($path, $schema, $value, $additional_properties) = @_;
1055 check_object
($path, $schema, $value, $additional_properties, $errors);
1056 if (scalar(%$errors)) {
1057 foreach my $k (keys %$errors) {
1058 warn "parse error: $k: $errors->{$k}\n";
1066 my ($value, $schema, $path, $errors) = @_;
1068 die "internal error - no schema" if !$schema;
1069 die "internal error" if !$errors;
1071 #print "check_prop $path\n" if $value;
1073 my $st = ref($schema);
1074 if (!$st || $st ne 'HASH') {
1075 add_error
($errors, $path, "Invalid schema definition.");
1079 # if it extends another schema, it must pass that schema as well
1080 if($schema->{extends
}) {
1081 check_prop
($value, $schema->{extends
}, $path, $errors);
1084 if (!defined ($value)) {
1085 return if $schema->{type
} && $schema->{type
} eq 'null';
1086 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
1087 add_error
($errors, $path, "property is missing and it is not optional");
1092 return if !check_type
($path, $schema->{type
}, $value, $errors);
1094 if ($schema->{disallow
}) {
1096 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
1097 add_error
($errors, $path, "disallowed value was matched");
1102 if (my $vt = ref($value)) {
1104 if ($vt eq 'ARRAY') {
1105 if ($schema->{items
}) {
1106 my $it = ref($schema->{items
});
1107 if ($it && $it eq 'ARRAY') {
1108 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1109 die "not implemented";
1112 foreach my $el (@$value) {
1113 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
1119 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
1120 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
1121 $value, $schema->{additionalProperties
}, $errors);
1127 if (my $format = $schema->{format
}) {
1128 eval { check_format
($format, $value, $path); };
1130 add_error
($errors, $path, "invalid format - $@");
1135 if (my $pattern = $schema->{pattern
}) {
1136 if ($value !~ m/^$pattern$/) {
1137 add_error
($errors, $path, "value does not match the regex pattern");
1142 if (defined (my $max = $schema->{maxLength
})) {
1143 if (length($value) > $max) {
1144 add_error
($errors, $path, "value may only be $max characters long");
1149 if (defined (my $min = $schema->{minLength
})) {
1150 if (length($value) < $min) {
1151 add_error
($errors, $path, "value must be at least $min characters long");
1156 if (is_number
($value)) {
1157 if (defined (my $max = $schema->{maximum
})) {
1158 if ($value > $max) {
1159 add_error
($errors, $path, "value must have a maximum value of $max");
1164 if (defined (my $min = $schema->{minimum
})) {
1165 if ($value < $min) {
1166 add_error
($errors, $path, "value must have a minimum value of $min");
1172 if (my $ea = $schema->{enum
}) {
1175 foreach my $ev (@$ea) {
1176 if ($ev eq $value) {
1182 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
1183 join(", ", @$ea) . "'");
1190 my ($instance, $schema, $errmsg) = @_;
1193 $errmsg = "Parameter verification failed.\n" if !$errmsg;
1195 # todo: cycle detection is only needed for debugging, I guess
1196 # we can disable that in the final release
1197 # todo: is there a better/faster way to detect cycles?
1199 # 'download' responses can contain a filehandle, don't cycle-check that as
1200 # it produces a warning
1201 my $is_download = ref($instance) eq 'HASH' && exists($instance->{download
});
1202 find_cycle
($instance, sub { $cycles = 1 }) if !$is_download;
1204 add_error
($errors, undef, "data structure contains recursive cycles");
1206 check_prop
($instance, $schema, '', $errors);
1209 if (scalar(%$errors)) {
1210 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1216 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1217 my $default_schema_noref = {
1218 description
=> "This is the JSON Schema for JSON Schemas.",
1219 type
=> [ "object" ],
1220 additionalProperties
=> 0,
1223 type
=> ["string", "array"],
1224 description
=> "This is a type definition value. This can be a simple type, or a union type",
1229 enum
=> $schema_valid_types,
1231 enum
=> $schema_valid_types,
1235 description
=> "This indicates that the instance property in the instance object is not required.",
1241 description
=> "This is a definition for the properties of an object value",
1247 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1251 additionalProperties
=> {
1252 type
=> [ "boolean", "object"],
1253 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1260 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1265 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1269 description
=> "When the instance value is a string, this indicates minimum length of the string",
1276 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1282 description
=> "A text representation of the type (used to generate documentation).",
1287 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.",
1294 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1299 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).",
1301 verbose_description
=> {
1304 description
=> "This provides a more verbose description.",
1306 format_description
=> {
1309 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1314 description
=> "This provides the title of the property",
1319 description
=> "This is used to provide rendering hints to format cli command output.",
1322 type
=> [ "string", "object" ],
1324 description
=> "indicates a required property or a schema that must be validated if this property is present",
1327 type
=> [ "string", "object" ],
1329 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",
1334 description
=> "Whether this is the default key in a comma separated list property string.",
1339 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.",
1344 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1345 requires
=> 'alias',
1350 description
=> "This indicates the default for the instance property."
1354 description
=> "Bash completion function. This function should return a list of possible values.",
1360 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.",
1365 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1368 # this is from hyper schema
1371 description
=> "This defines the link relations of the instance objects",
1378 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",
1382 description
=> "This is the name of the link relation",
1388 description
=> "For submission links, this defines the method that should be used to access the target resource",
1397 description
=> "For CLI context, this defines the maximal width to print before truncating",
1403 my $default_schema = Storable
::dclone
($default_schema_noref);
1405 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1406 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1408 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1409 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1411 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1412 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1414 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1415 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1417 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1418 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1420 my $method_schema = {
1422 additionalProperties
=> 0,
1425 description
=> "This a description of the method",
1430 description
=> "This indicates the name of the function to call.",
1433 additionalProperties
=> 1,
1448 description
=> "The HTTP method name.",
1449 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1454 description
=> "Method needs special privileges - only pvedaemon can execute it",
1459 description
=> "Method is available for clients authenticated using an API token.",
1465 description
=> "Method downloads the file content (filename is the return value of the method).",
1470 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1473 proxyto_callback
=> {
1475 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1480 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1482 additionalProperties
=> 0,
1485 description
=> "Describe access permissions.",
1489 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1491 enum
=> ['all', 'world'],
1495 description
=> "Array of permission checks (prefix notation).",
1502 description
=> "Used internally",
1506 description
=> "Used internally",
1511 description
=> "path for URL matching (uri template)",
1513 fragmentDelimiter
=> {
1515 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.",
1520 description
=> "JSON Schema for parameters.",
1525 description
=> "JSON Schema for return value.",
1530 description
=> "method implementation (code reference)",
1535 description
=> "Delegate call to this class (perl class string).",
1538 additionalProperties
=> 0,
1544 fragmentDelimiter
=> { optional
=> 1 }
1552 sub validate_schema
{
1555 my $errmsg = "internal error - unable to verify schema\n";
1556 validate
($schema, $default_schema, $errmsg);
1559 sub validate_method_info
{
1562 my $errmsg = "internal error - unable to verify method info\n";
1563 validate
($info, $method_schema, $errmsg);
1565 validate_schema
($info->{parameters
}) if $info->{parameters
};
1566 validate_schema
($info->{returns
}) if $info->{returns
};
1569 # run a self test on load
1570 # make sure we can verify the default schema
1571 validate_schema
($default_schema_noref);
1572 validate_schema
($method_schema);
1574 # and now some utility methods (used by pve api)
1575 sub method_get_child_link
{
1578 return undef if !$info;
1580 my $schema = $info->{returns
};
1581 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1583 my $links = $schema->{links
};
1584 return undef if !$links;
1587 foreach my $lnk (@$links) {
1588 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1597 # a way to parse command line parameters, using a
1598 # schema to configure Getopt::Long
1600 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1602 if (!$schema || !$schema->{properties
}) {
1603 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1604 if scalar(@$args) != 0;
1609 if ($arg_param && !ref($arg_param)) {
1610 my $pd = $schema->{properties
}->{$arg_param};
1611 die "expected list format $pd->{format}"
1612 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1613 $list_param = $arg_param;
1616 my @interactive = ();
1618 foreach my $prop (keys %{$schema->{properties
}}) {
1619 my $pd = $schema->{properties
}->{$prop};
1620 next if $list_param && $prop eq $list_param;
1621 next if defined($fixed_param->{$prop});
1623 my $mapping = $param_mapping_hash->{$prop};
1624 if ($mapping && $mapping->{interactive
}) {
1625 # interactive parameters such as passwords: make the argument
1626 # optional and call the mapping function afterwards.
1627 push @getopt, "$prop:s";
1628 push @interactive, [$prop, $mapping->{func
}];
1629 } elsif ($pd->{type
} eq 'boolean') {
1630 push @getopt, "$prop:s";
1632 if ($pd->{format
} && $pd->{format
} =~ m/-a?list/) {
1633 push @getopt, "$prop=s@";
1635 push @getopt, "$prop=s";
1640 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1643 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1644 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1648 $opts->{$list_param} = $args;
1650 } elsif (ref($arg_param)) {
1651 for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1652 my $arg_name = $arg_param->[$i];
1653 if ($opts->{'extra-args'}) {
1654 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1656 if ($arg_name eq 'extra-args') {
1657 $opts->{'extra-args'} = $args;
1662 # check if all left-over arg_param are optional, else we
1663 # must die as the mapping is then ambigious
1664 for (; $i < scalar(@$arg_param); $i++) {
1665 my $prop = $arg_param->[$i];
1666 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
)
1667 if !$schema->{properties
}->{$prop}->{optional
};
1669 if ($arg_param->[-1] eq 'extra-args') {
1670 $opts->{'extra-args'} = [];
1674 $opts->{$arg_name} = shift @$args;
1676 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1678 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1679 if scalar(@$args) != 0;
1682 if (ref($arg_param)) {
1683 foreach my $arg_name (@$arg_param) {
1684 if ($arg_name eq 'extra-args') {
1685 $opts->{'extra-args'} = [];
1686 } elsif (!$schema->{properties
}->{$arg_name}->{optional
}) {
1687 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1693 foreach my $entry (@interactive) {
1694 my ($opt, $func) = @$entry;
1695 my $pd = $schema->{properties
}->{$opt};
1696 my $value = $opts->{$opt};
1697 if (defined($value) || !$pd->{optional
}) {
1698 $opts->{$opt} = $func->($value);
1702 # decode after Getopt as we are not sure how well it handles unicode
1703 foreach my $p (keys %$opts) {
1704 if (!ref($opts->{$p})) {
1705 $opts->{$p} = decode
('locale', $opts->{$p});
1706 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1708 foreach my $v (@{$opts->{$p}}) {
1709 push @$tmp, decode
('locale', $v);
1712 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1713 $opts->{$p} = decode
('locale', $$opts->{$p});
1715 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1719 foreach my $p (keys %$opts) {
1720 if (my $pd = $schema->{properties
}->{$p}) {
1721 if ($pd->{type
} eq 'boolean') {
1722 if ($opts->{$p} eq '') {
1724 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1725 $opts->{$p} = $bool;
1727 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1729 } elsif ($pd->{format
}) {
1731 if ($pd->{format
} =~ m/-list/) {
1732 # allow --vmid 100 --vmid 101 and --vmid 100,101
1733 # allow --dow mon --dow fri and --dow mon,fri
1734 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1735 } elsif ($pd->{format
} =~ m/-alist/) {
1736 # we encode array as \0 separated strings
1737 # Note: CGI.pm also use this encoding
1738 if (scalar(@{$opts->{$p}}) != 1) {
1739 $opts->{$p} = join("\0", @{$opts->{$p}});
1741 # st that split_list knows it is \0 terminated
1742 my $v = $opts->{$p}->[0];
1743 $opts->{$p} = "$v\0";
1750 foreach my $p (keys %$fixed_param) {
1751 $opts->{$p} = $fixed_param->{$p};
1757 # A way to parse configuration data by giving a json schema
1759 my ($schema, $filename, $raw) = @_;
1761 # do fast check (avoid validate_schema($schema))
1762 die "got strange schema" if !$schema->{type
} ||
1763 !$schema->{properties
} || $schema->{type
} ne 'object';
1767 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1770 next if $line =~ /^#/;
1772 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1775 if ($schema->{properties
}->{$key} &&
1776 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1778 $value = parse_boolean
($value) // $value;
1780 $cfg->{$key} = $value;
1782 warn "ignore config line: $line\n"
1787 check_prop
($cfg, $schema, '', $errors);
1789 foreach my $k (keys %$errors) {
1790 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1797 # generate simple key/value file
1799 my ($schema, $filename, $cfg) = @_;
1801 # do fast check (avoid validate_schema($schema))
1802 die "got strange schema" if !$schema->{type
} ||
1803 !$schema->{properties
} || $schema->{type
} ne 'object';
1805 validate
($cfg, $schema, "validation error in '$filename'\n");
1809 foreach my $k (sort keys %$cfg) {
1810 $data .= "$k: $cfg->{$k}\n";
1816 # helpers used to generate our manual pages
1818 my $find_schema_default_key = sub {
1822 my $keyAliasProps = {};
1824 foreach my $key (keys %$format) {
1825 my $phash = $format->{$key};
1826 if ($phash->{default_key
}) {
1827 die "multiple default keys in schema ($default_key, $key)\n"
1828 if defined($default_key);
1829 die "default key '$key' is an alias - this is not allowed\n"
1830 if defined($phash->{alias
});
1831 die "default key '$key' with keyAlias attribute is not allowed\n"
1832 if $phash->{keyAlias
};
1833 $default_key = $key;
1835 my $key_alias = $phash->{keyAlias
};
1836 die "found keyAlias without 'alias definition for '$key'\n"
1837 if $key_alias && !$phash->{alias
};
1839 if ($phash->{alias
} && $key_alias) {
1840 die "inconsistent keyAlias '$key_alias' definition"
1841 if defined($keyAliasProps->{$key_alias}) &&
1842 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1843 $keyAliasProps->{$key_alias} = $phash->{alias
};
1847 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1850 sub generate_typetext
{
1851 my ($format, $list_enums) = @_;
1853 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1858 my $add_option_string = sub {
1859 my ($text, $optional) = @_;
1865 $text = "[$text]" if $optional;
1870 my $format_key_value = sub {
1871 my ($key, $phash) = @_;
1873 die "internal error" if defined($phash->{alias
});
1879 if (my $desc = $phash->{format_description
}) {
1880 $typetext .= "<$desc>";
1881 } elsif (my $text = $phash->{typetext
}) {
1883 } elsif (my $enum = $phash->{enum
}) {
1884 if ($list_enums || (scalar(@$enum) <= 3)) {
1885 $typetext .= '<' . join('|', @$enum) . '>';
1887 $typetext .= '<enum>';
1889 } elsif ($phash->{type
} eq 'boolean') {
1890 $typetext .= '<1|0>';
1891 } elsif ($phash->{type
} eq 'integer') {
1892 $typetext .= '<integer>';
1893 } elsif ($phash->{type
} eq 'number') {
1894 $typetext .= '<number>';
1896 die "internal error: neither format_description nor typetext found for option '$key'";
1899 if (defined($default_key) && ($default_key eq $key)) {
1900 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
1902 &$add_option_string("$keytext=$typetext", $phash->{optional
});
1908 my $cond_add_key = sub {
1911 return if $done->{$key}; # avoid duplicates
1915 my $phash = $format->{$key};
1917 return if !$phash; # should not happen
1919 return if $phash->{alias
};
1921 &$format_key_value($key, $phash);
1925 &$cond_add_key($default_key) if defined($default_key);
1927 # add required keys first
1928 foreach my $key (sort keys %$format) {
1929 my $phash = $format->{$key};
1930 &$cond_add_key($key) if $phash && !$phash->{optional
};
1934 foreach my $key (sort keys %$format) {
1935 &$cond_add_key($key);
1938 foreach my $keyAlias (sort keys %$keyAliasProps) {
1939 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1945 sub print_property_string
{
1946 my ($data, $format, $skip, $path) = @_;
1949 if (ref($format) ne 'HASH') {
1950 my $schema = get_format
($format);
1951 die "not a valid format: $format\n" if !$schema;
1952 # named formats can have validators attached
1953 $validator = $format_validators->{$format};
1958 check_object
($path, $format, $data, undef, $errors);
1959 if (scalar(%$errors)) {
1960 raise
"format error", errors
=> $errors;
1963 $data = $validator->($data) if $validator;
1965 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1970 my $add_option_string = sub {
1973 $res .= ',' if $add_sep;
1978 my $format_value = sub {
1979 my ($key, $value, $format) = @_;
1981 if (defined($format) && ($format eq 'disk-size')) {
1982 return format_size
($value);
1984 die "illegal value with commas for $key\n" if $value =~ /,/;
1989 my $done = { map { $_ => 1 } @$skip };
1991 my $cond_add_key = sub {
1992 my ($key, $isdefault) = @_;
1994 return if $done->{$key}; # avoid duplicates
1998 my $value = $data->{$key};
2000 return if !defined($value);
2002 my $phash = $format->{$key};
2004 # try to combine values if we have key aliases
2005 if (my $combine = $keyAliasProps->{$key}) {
2006 if (defined(my $combine_value = $data->{$combine})) {
2007 my $combine_format = $format->{$combine}->{format
};
2008 my $value_str = &$format_value($key, $value, $phash->{format
});
2009 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
2010 &$add_option_string("${value_str}=${combine_str}");
2011 $done->{$combine} = 1;
2016 if ($phash && $phash->{alias
}) {
2017 $phash = $format->{$phash->{alias
}};
2020 die "invalid key '$key'\n" if !$phash;
2021 die "internal error" if defined($phash->{alias
});
2023 my $value_str = &$format_value($key, $value, $phash->{format
});
2025 &$add_option_string($value_str);
2027 &$add_option_string("$key=${value_str}");
2031 # add default key first
2032 &$cond_add_key($default_key, 1) if defined($default_key);
2034 # add required keys first
2035 foreach my $key (sort keys %$data) {
2036 my $phash = $format->{$key};
2037 &$cond_add_key($key) if $phash && !$phash->{optional
};
2041 foreach my $key (sort keys %$data) {
2042 &$cond_add_key($key);
2048 sub schema_get_type_text
{
2049 my ($phash, $style) = @_;
2051 my $type = $phash->{type
} || 'string';
2053 if ($phash->{typetext
}) {
2054 return $phash->{typetext
};
2055 } elsif ($phash->{format_description
}) {
2056 return "<$phash->{format_description}>";
2057 } elsif ($phash->{enum
}) {
2058 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
2059 } elsif ($phash->{pattern
}) {
2060 return $phash->{pattern
};
2061 } elsif ($type eq 'integer' || $type eq 'number') {
2062 # NOTE: always access values as number (avoid converion to string)
2063 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
2064 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
2065 ($phash->{maximum
} + 0) . ")";
2066 } elsif (defined($phash->{minimum
})) {
2067 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
2068 } elsif (defined($phash->{maximum
})) {
2069 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
2071 } elsif ($type eq 'string') {
2072 if (my $format = $phash->{format
}) {
2073 $format = get_format
($format) if ref($format) ne 'HASH';
2074 if (ref($format) eq 'HASH') {
2076 $list_enums = 1 if $style && $style eq 'config-sub';
2077 return generate_typetext
($format, $list_enums);