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);
19 register_standard_option
25 our $CONFIGID_RE = qr/[a-z][a-z0-9_-]+/i;
27 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
28 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
29 # see: http://json-schema.org/
31 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
33 my $standard_options = {};
34 sub register_standard_option
{
35 my ($name, $schema) = @_;
37 die "standard option '$name' already registered\n"
38 if $standard_options->{$name};
40 $standard_options->{$name} = $schema;
43 sub get_standard_option
{
44 my ($name, $base) = @_;
46 my $std = $standard_options->{$name};
47 die "no such standard option '$name'\n" if !$std;
49 my $res = $base || {};
51 foreach my $opt (keys %$std) {
52 next if defined($res->{$opt});
53 $res->{$opt} = $std->{$opt};
59 register_standard_option
('pve-vmid', {
60 description
=> "The (unique) ID of the VM.",
61 type
=> 'integer', format
=> 'pve-vmid',
65 register_standard_option
('pve-node', {
66 description
=> "The cluster node name.",
67 type
=> 'string', format
=> 'pve-node',
70 register_standard_option
('pve-node-list', {
71 description
=> "List of cluster node names.",
72 type
=> 'string', format
=> 'pve-node-list',
75 register_standard_option
('pve-iface', {
76 description
=> "Network interface name.",
77 type
=> 'string', format
=> 'pve-iface',
78 minLength
=> 2, maxLength
=> 20,
81 register_standard_option
('pve-storage-id', {
82 description
=> "The storage identifier.",
83 type
=> 'string', format
=> 'pve-storage-id',
86 register_standard_option
('pve-bridge-id', {
87 description
=> "Bridge to attach guest network devices to.",
88 type
=> 'string', format
=> 'pve-bridge-id',
89 format_description
=> 'bridge',
92 register_standard_option
('pve-config-digest', {
93 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
96 maxLength
=> 40, # sha1 hex digest length is 40
99 register_standard_option
('skiplock', {
100 description
=> "Ignore locks - only root is allowed to use this option.",
105 register_standard_option
('extra-args', {
106 description
=> "Extra arguments as array",
108 items
=> { type
=> 'string' },
112 register_standard_option
('fingerprint-sha256', {
113 description
=> "Certificate SHA 256 fingerprint.",
115 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
118 register_standard_option
('pve-output-format', {
120 description
=> 'Output format.',
121 enum
=> [ 'text', 'json', 'json-pretty', 'yaml' ],
126 register_standard_option
('pve-snapshot-name', {
127 description
=> "The name of the snapshot.",
128 type
=> 'string', format
=> 'pve-configid',
132 my $format_list = {};
133 my $format_validators = {};
135 sub register_format
{
136 my ($name, $format, $validator) = @_;
138 die "JSON schema format '$name' already registered\n"
139 if $format_list->{$name};
142 die "A \$validator function can only be specified for hash-based formats\n"
143 if ref($format) ne 'HASH';
144 $format_validators->{$name} = $validator;
147 $format_list->{$name} = $format;
152 return $format_list->{$name};
155 my $renderer_hash = {};
157 sub register_renderer
{
158 my ($name, $code) = @_;
160 die "renderer '$name' already registered\n"
161 if $renderer_hash->{$name};
163 $renderer_hash->{$name} = $code;
168 return $renderer_hash->{$name};
171 # register some common type for pve
173 register_format
('string', sub {}); # allow format => 'string-list'
175 register_format
('urlencoded', \
&pve_verify_urlencoded
);
176 sub pve_verify_urlencoded
{
177 my ($text, $noerr) = @_;
178 if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
179 return undef if $noerr;
180 die "invalid urlencoded string: $text\n";
185 register_format
('pve-configid', \
&pve_verify_configid
);
186 sub pve_verify_configid
{
187 my ($id, $noerr) = @_;
189 if ($id !~ m/^$CONFIGID_RE$/) {
190 return undef if $noerr;
191 die "invalid configuration ID '$id'\n";
196 PVE
::JSONSchema
::register_format
('pve-storage-id', \
&parse_storage_id
);
197 sub parse_storage_id
{
198 my ($storeid, $noerr) = @_;
200 return parse_id
($storeid, 'storage', $noerr);
203 PVE
::JSONSchema
::register_format
('pve-bridge-id', \
&parse_bridge_id
);
204 sub parse_bridge_id
{
205 my ($id, $noerr) = @_;
207 if ($id !~ m/^[-_.\w\d]+$/) {
208 return undef if $noerr;
209 die "invalid bridge ID '$id'\n";
214 PVE
::JSONSchema
::register_format
('acme-plugin-id', \
&parse_acme_plugin_id
);
215 sub parse_acme_plugin_id
{
216 my ($pluginid, $noerr) = @_;
218 return parse_id
($pluginid, 'ACME plugin', $noerr);
222 my ($id, $type, $noerr) = @_;
224 if ($id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
225 return undef if $noerr;
226 die "$type ID '$id' contains illegal characters\n";
231 register_format
('pve-vmid', \
&pve_verify_vmid
);
232 sub pve_verify_vmid
{
233 my ($vmid, $noerr) = @_;
235 if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
236 return undef if $noerr;
237 die "value does not look like a valid VM ID\n";
242 register_format
('pve-node', \
&pve_verify_node_name
);
243 sub pve_verify_node_name
{
244 my ($node, $noerr) = @_;
246 if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
247 return undef if $noerr;
248 die "value does not look like a valid node name\n";
253 # maps source to target ID using an ID map
255 my ($map, $source) = @_;
257 return $source if !defined($map);
259 return $map->{entries
}->{$source}
260 if $map->{entries
} && defined($map->{entries
}->{$source});
262 return $map->{default} if $map->{default};
264 # identity (fallback)
269 my ($idmap, $idformat) = @_;
271 return undef if !$idmap;
275 foreach my $entry (PVE
::Tools
::split_list
($idmap)) {
277 $map->{identity
} = 1;
278 } elsif ($entry =~ m/^([^:]+):([^:]+)$/) {
279 my ($source, $target) = ($1, $2);
281 check_format
($idformat, $source, '');
282 check_format
($idformat, $target, '');
284 die "entry '$entry' contains invalid ID - $@\n" if $@;
286 die "duplicate mapping for source '$source'\n"
287 if exists $map->{entries
}->{$source};
289 $map->{entries
}->{$source} = $target;
292 check_format
($idformat, $entry);
294 die "entry '$entry' contains invalid ID - $@\n" if $@;
296 die "default target ID can only be provided once\n"
297 if exists $map->{default};
299 $map->{default} = $entry;
303 die "identity mapping cannot be combined with other mappings\n"
304 if $map->{identity
} && ($map->{default} || exists $map->{entries
});
309 my $verify_idpair = sub {
310 my ($input, $noerr, $format) = @_;
312 eval { parse_idmap
($input, $format) };
314 return undef if $noerr;
321 PVE
::JSONSchema
::register_standard_option
('pve-targetstorage', {
322 description
=> "Mapping from source to target storages. Providing only a single storage ID maps all source storages to that storage. Providing the special value '1' will map each source storage to itself.",
324 format
=> 'storage-pair-list',
328 # note: this only checks a single list entry
329 # when using a storage-pair-list map, you need to pass the full parameter to
331 register_format
('storage-pair', \
&verify_storagepair
);
332 sub verify_storagepair
{
333 my ($storagepair, $noerr) = @_;
334 return $verify_idpair->($storagepair, $noerr, 'pve-storage-id');
337 # note: this only checks a single list entry
338 # when using a bridge-pair-list map, you need to pass the full parameter to
340 register_format
('bridge-pair', \
&verify_bridgepair
);
341 sub verify_bridgepair
{
342 my ($bridgepair, $noerr) = @_;
343 return $verify_idpair->($bridgepair, $noerr, 'pve-bridge-id');
346 register_format
('mac-addr', \
&pve_verify_mac_addr
);
347 sub pve_verify_mac_addr
{
348 my ($mac_addr, $noerr) = @_;
350 # don't allow I/G bit to be set, most of the time it breaks things, see:
351 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
352 if ($mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i) {
353 return undef if $noerr;
354 die "value does not look like a valid unicast MAC address\n";
359 register_standard_option
('mac-addr', {
361 description
=> 'Unicast MAC address.',
362 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.',
363 format_description
=> "XX:XX:XX:XX:XX:XX",
365 format
=> 'mac-addr',
368 register_format
('ipv4', \
&pve_verify_ipv4
);
369 sub pve_verify_ipv4
{
370 my ($ipv4, $noerr) = @_;
372 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
373 return undef if $noerr;
374 die "value does not look like a valid IPv4 address\n";
379 register_format
('ipv6', \
&pve_verify_ipv6
);
380 sub pve_verify_ipv6
{
381 my ($ipv6, $noerr) = @_;
383 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
384 return undef if $noerr;
385 die "value does not look like a valid IPv6 address\n";
390 register_format
('ip', \
&pve_verify_ip
);
392 my ($ip, $noerr) = @_;
394 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
395 return undef if $noerr;
396 die "value does not look like a valid IP address\n";
401 PVE
::JSONSchema
::register_format
('ldap-simple-attr', \
&verify_ldap_simple_attr
);
402 sub verify_ldap_simple_attr
{
403 my ($attr, $noerr) = @_;
405 if ($attr =~ m/^[a-zA-Z0-9]+$/) {
409 die "value '$attr' does not look like a simple ldap attribute name\n" if !$noerr;
414 my $ipv4_mask_hash = {
432 '255.255.128.0' => 17,
433 '255.255.192.0' => 18,
434 '255.255.224.0' => 19,
435 '255.255.240.0' => 20,
436 '255.255.248.0' => 21,
437 '255.255.252.0' => 22,
438 '255.255.254.0' => 23,
439 '255.255.255.0' => 24,
440 '255.255.255.128' => 25,
441 '255.255.255.192' => 26,
442 '255.255.255.224' => 27,
443 '255.255.255.240' => 28,
444 '255.255.255.248' => 29,
445 '255.255.255.252' => 30,
446 '255.255.255.254' => 31,
447 '255.255.255.255' => 32,
450 sub get_netmask_bits
{
452 return $ipv4_mask_hash->{$mask};
455 register_format
('ipv4mask', \
&pve_verify_ipv4mask
);
456 sub pve_verify_ipv4mask
{
457 my ($mask, $noerr) = @_;
459 if (!defined($ipv4_mask_hash->{$mask})) {
460 return undef if $noerr;
461 die "value does not look like a valid IP netmask\n";
466 register_format
('CIDRv6', \
&pve_verify_cidrv6
);
467 sub pve_verify_cidrv6
{
468 my ($cidr, $noerr) = @_;
470 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
474 return undef if $noerr;
475 die "value does not look like a valid IPv6 CIDR network\n";
478 register_format
('CIDRv4', \
&pve_verify_cidrv4
);
479 sub pve_verify_cidrv4
{
480 my ($cidr, $noerr) = @_;
482 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
486 return undef if $noerr;
487 die "value does not look like a valid IPv4 CIDR network\n";
490 register_format
('CIDR', \
&pve_verify_cidr
);
491 sub pve_verify_cidr
{
492 my ($cidr, $noerr) = @_;
494 if (!(pve_verify_cidrv4
($cidr, 1) ||
495 pve_verify_cidrv6
($cidr, 1)))
497 return undef if $noerr;
498 die "value does not look like a valid CIDR network\n";
504 register_format
('pve-ipv4-config', \
&pve_verify_ipv4_config
);
505 sub pve_verify_ipv4_config
{
506 my ($config, $noerr) = @_;
508 return $config if $config =~ /^(?:dhcp|manual)$/ ||
509 pve_verify_cidrv4
($config, 1);
510 return undef if $noerr;
511 die "value does not look like a valid ipv4 network configuration\n";
514 register_format
('pve-ipv6-config', \
&pve_verify_ipv6_config
);
515 sub pve_verify_ipv6_config
{
516 my ($config, $noerr) = @_;
518 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
519 pve_verify_cidrv6
($config, 1);
520 return undef if $noerr;
521 die "value does not look like a valid ipv6 network configuration\n";
524 register_format
('email', \
&pve_verify_email
);
525 sub pve_verify_email
{
526 my ($email, $noerr) = @_;
528 if ($email !~ /^$PVE::Tools::EMAIL_RE$/) {
529 return undef if $noerr;
530 die "value does not look like a valid email address\n";
535 register_format
('email-or-username', \
&pve_verify_email_or_username
);
536 sub pve_verify_email_or_username
{
537 my ($email, $noerr) = @_;
539 if ($email !~ /^$PVE::Tools::EMAIL_RE$/ &&
540 $email !~ /^$PVE::Tools::EMAIL_USER_RE$/) {
541 return undef if $noerr;
542 die "value does not look like a valid email address or user name\n";
547 register_format
('dns-name', \
&pve_verify_dns_name
);
548 sub pve_verify_dns_name
{
549 my ($name, $noerr) = @_;
551 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
553 if ($name !~ /^(${namere}\.)*${namere}$/) {
554 return undef if $noerr;
555 die "value does not look like a valid DNS name\n";
560 register_format
('timezone', \
&pve_verify_timezone
);
561 sub pve_verify_timezone
{
562 my ($timezone, $noerr) = @_;
564 return $timezone if $timezone eq 'UTC';
566 open(my $fh, "<", "/usr/share/zoneinfo/zone.tab");
567 while (my $line = <$fh>) {
568 next if $line =~ /^\s*#/;
570 my $zone = (split /\t/, $line)[2];
571 return $timezone if $timezone eq $zone; # found
575 return undef if $noerr;
576 die "invalid time zone '$timezone'\n";
579 # network interface name
580 register_format
('pve-iface', \
&pve_verify_iface
);
581 sub pve_verify_iface
{
582 my ($id, $noerr) = @_;
584 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
585 return undef if $noerr;
586 die "invalid network interface name '$id'\n";
591 # general addresses by name or IP
592 register_format
('address', \
&pve_verify_address
);
593 sub pve_verify_address
{
594 my ($addr, $noerr) = @_;
596 if (!(pve_verify_ip
($addr, 1) ||
597 pve_verify_dns_name
($addr, 1)))
599 return undef if $noerr;
600 die "value does not look like a valid address: $addr\n";
605 register_format
('disk-size', \
&pve_verify_disk_size
);
606 sub pve_verify_disk_size
{
607 my ($size, $noerr) = @_;
608 if (!defined(parse_size
($size))) {
609 return undef if $noerr;
610 die "value does not look like a valid disk size: $size\n";
615 register_standard_option
('spice-proxy', {
616 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).",
617 type
=> 'string', format
=> 'address',
620 register_standard_option
('remote-viewer-config', {
621 description
=> "Returned values can be directly passed to the 'remote-viewer' application.",
622 additionalProperties
=> 1,
624 type
=> { type
=> 'string' },
625 password
=> { type
=> 'string' },
626 proxy
=> { type
=> 'string' },
627 host
=> { type
=> 'string' },
628 'tls-port' => { type
=> 'integer' },
632 register_format
('pve-startup-order', \
&pve_verify_startup_order
);
633 sub pve_verify_startup_order
{
634 my ($value, $noerr) = @_;
636 return $value if pve_parse_startup_order
($value);
638 return undef if $noerr;
640 die "unable to parse startup options\n";
645 type
=> 'number', minimum
=> '0',
646 format_description
=> 'LIMIT',
649 my $bwlimit_format = {
652 description
=> 'default bandwidth limit in KiB/s',
656 description
=> 'bandwidth limit in KiB/s for restoring guests from backups',
660 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)',
664 description
=> 'bandwidth limit in KiB/s for cloning disks',
668 description
=> 'bandwidth limit in KiB/s for moving disks',
671 register_format
('bwlimit', $bwlimit_format);
672 register_standard_option
('bwlimit', {
673 description
=> "Set I/O bandwidth limit for various operations (in KiB/s).",
676 format
=> $bwlimit_format,
679 my $remote_format = {
682 format_description
=> 'Remote Proxmox hostname or IP',
690 format_description
=> 'A full Proxmox API token including the secret value.',
692 fingerprint
=> get_standard_option
(
693 'fingerprint-sha256',
696 format_description
=> 'Remote host\'s certificate fingerprint, if not trusted by system store.',
700 register_format
('proxmox-remote', $remote_format);
701 register_standard_option
('proxmox-remote', {
702 description
=> "Specification of a remote endpoint.",
703 type
=> 'string', format
=> 'proxmox-remote',
706 our $PVE_TAG_RE = qr/[a-z0-9_][a-z0-9_\-\+\.]*/i;
708 # used for pve-tag-list in e.g., guest configs
709 register_format
('pve-tag', \
&pve_verify_tag
);
711 my ($value, $noerr) = @_;
713 return $value if $value =~ m/^${PVE_TAG_RE}$/i;
715 return undef if $noerr;
717 die "invalid characters in tag\n";
720 sub pve_parse_startup_order
{
723 return undef if !$value;
727 foreach my $p (split(/,/, $value)) {
728 next if $p =~ m/^\s*$/;
730 if ($p =~ m/^(order=)?(\d+)$/) {
732 } elsif ($p =~ m/^up=(\d+)$/) {
734 } elsif ($p =~ m/^down=(\d+)$/) {
744 PVE
::JSONSchema
::register_standard_option
('pve-startup-order', {
745 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.",
747 type
=> 'string', format
=> 'pve-startup-order',
748 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ',
751 register_format
('pve-tfa-secret', \
&pve_verify_tfa_secret
);
752 sub pve_verify_tfa_secret
{
753 my ($key, $noerr) = @_;
755 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
756 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
757 # format to support arbitrary lengths properly:
758 if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
759 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
760 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
765 return undef if $noerr;
767 die "unable to decode TFA secret\n";
771 PVE
::JSONSchema
::register_format
('pve-task-status-type', \
&verify_task_status_type
);
772 sub verify_task_status_type
{
773 my ($value, $noerr) = @_;
775 return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
777 return undef if $noerr;
779 die "invalid status '$value'\n";
783 my ($format, $value, $path) = @_;
785 if (ref($format) eq 'HASH') {
786 # hash ref cannot have validator/list/opt handling attached
787 return parse_property_string
($format, $value, $path);
790 if (ref($format) eq 'CODE') {
791 # we are the (sole, old-style) validator
792 return $format->($value);
795 return if $format eq 'regex';
798 $format =~ m/^(.*?)(?:-a?(list|opt))?$/;
799 my ($format_name, $format_type) = ($1, $2 // 'none');
800 my $registered = get_format
($format_name);
801 die "undefined format '$format'\n" if !$registered;
803 die "'-$format_type' format must have code ref, not hash\n"
804 if $format_type ne 'none' && ref($registered) ne 'CODE';
806 if ($format_type eq 'list') {
808 # Note: we allow empty lists
809 foreach my $v (split_list
($value)) {
810 push @{$parsed}, $registered->($v);
812 } elsif ($format_type eq 'opt') {
813 $parsed = $registered->($value) if $value;
815 if (ref($registered) eq 'HASH') {
816 # Note: this is the only case where a validator function could be
817 # attached, hence it's safe to handle that in parse_property_string.
818 # We do however have to call it with $format_name instead of
819 # $registered, so it knows about the name (and thus any validators).
820 $parsed = parse_property_string
($format, $value, $path);
822 $parsed = $registered->($value);
832 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
833 my ($size, $unit) = ($1, $3);
836 $size = $size * 1024;
837 } elsif ($unit eq 'M') {
838 $size = $size * 1024 * 1024;
839 } elsif ($unit eq 'G') {
840 $size = $size * 1024 * 1024 * 1024;
841 } elsif ($unit eq 'T') {
842 $size = $size * 1024 * 1024 * 1024 * 1024;
853 my $kb = int($size/1024);
854 return $size if $kb*1024 != $size;
856 my $mb = int($kb/1024);
857 return "${kb}K" if $mb*1024 != $kb;
859 my $gb = int($mb/1024);
860 return "${mb}M" if $gb*1024 != $mb;
862 my $tb = int($gb/1024);
863 return "${gb}G" if $tb*1024 != $gb;
870 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
871 return 0 if $bool =~ m/^(0|off|no|false)$/i;
875 sub parse_property_string
{
876 my ($format, $data, $path, $additional_properties) = @_;
878 # In property strings we default to not allowing additional properties
879 $additional_properties = 0 if !defined($additional_properties);
881 # Support named formats here, too:
884 if (my $reg = get_format
($format)) {
885 die "parse_property_string only accepts hash based named formats\n"
886 if ref($reg) ne 'HASH';
888 # named formats can have validators attached
889 $validator = $format_validators->{$format};
893 die "unknown format: $format\n";
895 } elsif (ref($format) ne 'HASH') {
896 die "unexpected format value of type ".ref($format)."\n";
902 foreach my $part (split(/,/, $data)) {
903 next if $part =~ /^\s*$/;
905 if ($part =~ /^([^=]+)=(.+)$/) {
906 my ($k, $v) = ($1, $2);
907 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
908 my $schema = $format->{$k};
909 if (my $alias = $schema->{alias
}) {
910 if (my $key_alias = $schema->{keyAlias
}) {
911 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
912 $res->{$key_alias} = $k;
915 $schema = $format->{$k};
918 die "invalid key in comma-separated list property: $k\n" if !$schema;
919 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
920 $v = parse_boolean
($v) // $v;
923 } elsif ($part !~ /=/) {
924 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
925 foreach my $key (keys %$format) {
926 if ($format->{$key}->{default_key
}) {
928 if (!$res->{$default_key}) {
929 $res->{$default_key} = $part;
932 die "duplicate key in comma-separated list property: $default_key\n";
935 die "value without key, but schema does not define a default key\n" if !$default_key;
937 die "missing key in comma-separated list property\n";
942 check_object
($path, $format, $res, $additional_properties, $errors);
943 if (scalar(%$errors)) {
944 raise
"format error\n", errors
=> $errors;
947 return $validator->($res) if $validator;
952 my ($errors, $path, $msg) = @_;
954 $path = '_root' if !$path;
956 if ($errors->{$path}) {
957 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
959 $errors->{$path} = $msg;
966 # see 'man perlretut'
967 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
973 return $value =~ m/^[+-]?\d+$/;
977 my ($path, $type, $value, $errors) = @_;
981 if (!defined($value)) {
982 return 1 if $type eq 'null';
986 if (my $tt = ref($type)) {
987 if ($tt eq 'ARRAY') {
988 foreach my $t (@$type) {
990 check_type
($path, $t, $value, $tmperr);
991 return 1 if !scalar(%$tmperr);
993 my $ttext = join ('|', @$type);
994 add_error
($errors, $path, "type check ('$ttext') failed");
996 } elsif ($tt eq 'HASH') {
998 check_prop
($value, $type, $path, $tmperr);
999 return 1 if !scalar(%$tmperr);
1000 add_error
($errors, $path, "type check failed");
1003 die "internal error - got reference type '$tt'";
1008 return 1 if $type eq 'any';
1010 if ($type eq 'null') {
1011 if (defined($value)) {
1012 add_error
($errors, $path, "type check ('$type') failed - value is not null");
1018 my $vt = ref($value);
1020 if ($type eq 'array') {
1021 if (!$vt || $vt ne 'ARRAY') {
1022 add_error
($errors, $path, "type check ('$type') failed");
1026 } elsif ($type eq 'object') {
1027 if (!$vt || $vt ne 'HASH') {
1028 add_error
($errors, $path, "type check ('$type') failed");
1032 } elsif ($type eq 'coderef') {
1033 if (!$vt || $vt ne 'CODE') {
1034 add_error
($errors, $path, "type check ('$type') failed");
1038 } elsif ($type eq 'string' && $vt eq 'Regexp') {
1039 # qr// regexes can be used as strings and make sense for format=regex
1043 add_error
($errors, $path, "type check ('$type') failed - got $vt");
1046 if ($type eq 'string') {
1047 return 1; # nothing to check ?
1048 } elsif ($type eq 'boolean') {
1049 #if ($value =~ m/^(1|true|yes|on)$/i) {
1050 if ($value eq '1') {
1052 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
1053 } elsif ($value eq '0') {
1054 return 1; # return success (not value)
1056 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1059 } elsif ($type eq 'integer') {
1060 if (!is_integer
($value)) {
1061 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1065 } elsif ($type eq 'number') {
1066 if (!is_number
($value)) {
1067 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1072 return 1; # no need to verify unknown types
1082 my ($path, $schema, $value, $additional_properties, $errors) = @_;
1084 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
1086 my $st = ref($schema);
1087 if (!$st || $st ne 'HASH') {
1088 add_error
($errors, $path, "Invalid schema definition.");
1092 my $vt = ref($value);
1093 if (!$vt || $vt ne 'HASH') {
1094 add_error
($errors, $path, "an object is required");
1098 foreach my $k (keys %$schema) {
1099 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
1102 foreach my $k (keys %$value) {
1104 my $newpath = $path ?
"$path.$k" : $k;
1106 if (my $subschema = $schema->{$k}) {
1107 if (my $requires = $subschema->{requires
}) {
1108 if (ref($requires)) {
1109 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1110 check_prop
($value, $requires, $path, $errors);
1111 } elsif (!defined($value->{$requires})) {
1112 add_error
($errors, $path ?
"$path.$requires" : $requires,
1113 "missing property - '$newpath' requires this property");
1117 next; # value is already checked above
1120 if (defined ($additional_properties) && !$additional_properties) {
1121 add_error
($errors, $newpath, "property is not defined in schema " .
1122 "and the schema does not allow additional properties");
1125 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
1126 if ref($additional_properties);
1130 sub check_object_warn
{
1131 my ($path, $schema, $value, $additional_properties) = @_;
1133 check_object
($path, $schema, $value, $additional_properties, $errors);
1134 if (scalar(%$errors)) {
1135 foreach my $k (keys %$errors) {
1136 warn "parse error: $k: $errors->{$k}\n";
1144 my ($value, $schema, $path, $errors) = @_;
1146 die "internal error - no schema" if !$schema;
1147 die "internal error" if !$errors;
1149 #print "check_prop $path\n" if $value;
1151 my $st = ref($schema);
1152 if (!$st || $st ne 'HASH') {
1153 add_error
($errors, $path, "Invalid schema definition.");
1157 # if it extends another schema, it must pass that schema as well
1158 if($schema->{extends
}) {
1159 check_prop
($value, $schema->{extends
}, $path, $errors);
1162 if (!defined ($value)) {
1163 return if $schema->{type
} && $schema->{type
} eq 'null';
1164 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
1165 add_error
($errors, $path, "property is missing and it is not optional");
1170 return if !check_type
($path, $schema->{type
}, $value, $errors);
1172 if ($schema->{disallow
}) {
1174 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
1175 add_error
($errors, $path, "disallowed value was matched");
1180 if (my $vt = ref($value)) {
1182 if ($vt eq 'ARRAY') {
1183 if ($schema->{items
}) {
1184 my $it = ref($schema->{items
});
1185 if ($it && $it eq 'ARRAY') {
1186 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1187 die "not implemented";
1190 foreach my $el (@$value) {
1191 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
1197 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
1198 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
1199 $value, $schema->{additionalProperties
}, $errors);
1205 if (my $format = $schema->{format
}) {
1206 eval { check_format
($format, $value, $path); };
1208 add_error
($errors, $path, "invalid format - $@");
1213 if (my $pattern = $schema->{pattern
}) {
1214 if ($value !~ m/^$pattern$/) {
1215 add_error
($errors, $path, "value does not match the regex pattern");
1220 if (defined (my $max = $schema->{maxLength
})) {
1221 if (length($value) > $max) {
1222 add_error
($errors, $path, "value may only be $max characters long");
1227 if (defined (my $min = $schema->{minLength
})) {
1228 if (length($value) < $min) {
1229 add_error
($errors, $path, "value must be at least $min characters long");
1234 if (is_number
($value)) {
1235 if (defined (my $max = $schema->{maximum
})) {
1236 if ($value > $max) {
1237 add_error
($errors, $path, "value must have a maximum value of $max");
1242 if (defined (my $min = $schema->{minimum
})) {
1243 if ($value < $min) {
1244 add_error
($errors, $path, "value must have a minimum value of $min");
1250 if (my $ea = $schema->{enum
}) {
1253 foreach my $ev (@$ea) {
1254 if ($ev eq $value) {
1260 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
1261 join(", ", @$ea) . "'");
1268 my ($instance, $schema, $errmsg) = @_;
1271 $errmsg = "Parameter verification failed.\n" if !$errmsg;
1273 # todo: cycle detection is only needed for debugging, I guess
1274 # we can disable that in the final release
1275 # todo: is there a better/faster way to detect cycles?
1277 # 'download' responses can contain a filehandle, don't cycle-check that as
1278 # it produces a warning
1279 my $is_download = ref($instance) eq 'HASH' && exists($instance->{download
});
1280 find_cycle
($instance, sub { $cycles = 1 }) if !$is_download;
1282 add_error
($errors, undef, "data structure contains recursive cycles");
1284 check_prop
($instance, $schema, '', $errors);
1287 if (scalar(%$errors)) {
1288 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1294 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1295 my $default_schema_noref = {
1296 description
=> "This is the JSON Schema for JSON Schemas.",
1297 type
=> [ "object" ],
1298 additionalProperties
=> 0,
1301 type
=> ["string", "array"],
1302 description
=> "This is a type definition value. This can be a simple type, or a union type",
1307 enum
=> $schema_valid_types,
1309 enum
=> $schema_valid_types,
1313 description
=> "This indicates that the instance property in the instance object is not required.",
1319 description
=> "This is a definition for the properties of an object value",
1325 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1329 additionalProperties
=> {
1330 type
=> [ "boolean", "object"],
1331 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1338 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1343 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1347 description
=> "When the instance value is a string, this indicates minimum length of the string",
1354 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1360 description
=> "A text representation of the type (used to generate documentation).",
1365 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.",
1372 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1377 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).",
1379 verbose_description
=> {
1382 description
=> "This provides a more verbose description.",
1384 format_description
=> {
1387 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1392 description
=> "This provides the title of the property",
1397 description
=> "This is used to provide rendering hints to format cli command output.",
1400 type
=> [ "string", "object" ],
1402 description
=> "indicates a required property or a schema that must be validated if this property is present",
1405 type
=> [ "string", "object" ],
1407 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",
1412 description
=> "Whether this is the default key in a comma separated list property string.",
1417 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.",
1422 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1423 requires
=> 'alias',
1428 description
=> "This indicates the default for the instance property."
1432 description
=> "Bash completion function. This function should return a list of possible values.",
1438 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.",
1443 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1446 # this is from hyper schema
1449 description
=> "This defines the link relations of the instance objects",
1456 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",
1460 description
=> "This is the name of the link relation",
1466 description
=> "For submission links, this defines the method that should be used to access the target resource",
1475 description
=> "For CLI context, this defines the maximal width to print before truncating",
1481 my $default_schema = Storable
::dclone
($default_schema_noref);
1483 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1484 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1486 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1487 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1489 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1490 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1492 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1493 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1495 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1496 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1498 my $method_schema = {
1500 additionalProperties
=> 0,
1503 description
=> "This a description of the method",
1508 description
=> "This indicates the name of the function to call.",
1511 additionalProperties
=> 1,
1526 description
=> "The HTTP method name.",
1527 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1532 description
=> "Method needs special privileges - only pvedaemon can execute it",
1537 description
=> "Method is available for clients authenticated using an API token.",
1543 description
=> "Method downloads the file content (filename is the return value of the method).",
1548 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1551 proxyto_callback
=> {
1553 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1558 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1560 additionalProperties
=> 0,
1563 description
=> "Describe access permissions.",
1567 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1569 enum
=> ['all', 'world'],
1573 description
=> "Array of permission checks (prefix notation).",
1580 description
=> "Used internally",
1584 description
=> "Used internally",
1589 description
=> "path for URL matching (uri template)",
1591 fragmentDelimiter
=> {
1593 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.",
1598 description
=> "JSON Schema for parameters.",
1603 description
=> "JSON Schema for return value.",
1608 description
=> "method implementation (code reference)",
1613 description
=> "Delegate call to this class (perl class string).",
1616 additionalProperties
=> 0,
1622 fragmentDelimiter
=> { optional
=> 1 }
1630 sub validate_schema
{
1633 my $errmsg = "internal error - unable to verify schema\n";
1634 validate
($schema, $default_schema, $errmsg);
1637 sub validate_method_info
{
1640 my $errmsg = "internal error - unable to verify method info\n";
1641 validate
($info, $method_schema, $errmsg);
1643 validate_schema
($info->{parameters
}) if $info->{parameters
};
1644 validate_schema
($info->{returns
}) if $info->{returns
};
1647 # run a self test on load
1648 # make sure we can verify the default schema
1649 validate_schema
($default_schema_noref);
1650 validate_schema
($method_schema);
1652 # and now some utility methods (used by pve api)
1653 sub method_get_child_link
{
1656 return undef if !$info;
1658 my $schema = $info->{returns
};
1659 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1661 my $links = $schema->{links
};
1662 return undef if !$links;
1665 foreach my $lnk (@$links) {
1666 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1675 # a way to parse command line parameters, using a
1676 # schema to configure Getopt::Long
1678 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1680 if (!$schema || !$schema->{properties
}) {
1681 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1682 if scalar(@$args) != 0;
1687 if ($arg_param && !ref($arg_param)) {
1688 my $pd = $schema->{properties
}->{$arg_param};
1689 die "expected list format $pd->{format}"
1690 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1691 $list_param = $arg_param;
1694 my @interactive = ();
1696 foreach my $prop (keys %{$schema->{properties
}}) {
1697 my $pd = $schema->{properties
}->{$prop};
1698 next if $list_param && $prop eq $list_param;
1699 next if defined($fixed_param->{$prop});
1701 my $mapping = $param_mapping_hash->{$prop};
1702 if ($mapping && $mapping->{interactive
}) {
1703 # interactive parameters such as passwords: make the argument
1704 # optional and call the mapping function afterwards.
1705 push @getopt, "$prop:s";
1706 push @interactive, [$prop, $mapping->{func
}];
1707 } elsif ($pd->{type
} eq 'boolean') {
1708 push @getopt, "$prop:s";
1710 if ($pd->{format
} && $pd->{format
} =~ m/-a?list/) {
1711 push @getopt, "$prop=s@";
1712 } elsif ($pd->{type
} eq 'array') {
1713 push @getopt, "$prop=s@";
1715 push @getopt, "$prop=s";
1720 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1723 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1724 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1728 $opts->{$list_param} = $args;
1730 } elsif (ref($arg_param)) {
1731 for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1732 my $arg_name = $arg_param->[$i];
1733 if ($opts->{'extra-args'}) {
1734 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1736 if ($arg_name eq 'extra-args') {
1737 $opts->{'extra-args'} = $args;
1742 # check if all left-over arg_param are optional, else we
1743 # must die as the mapping is then ambigious
1744 for (; $i < scalar(@$arg_param); $i++) {
1745 my $prop = $arg_param->[$i];
1746 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
)
1747 if !$schema->{properties
}->{$prop}->{optional
};
1749 if ($arg_param->[-1] eq 'extra-args') {
1750 $opts->{'extra-args'} = [];
1754 $opts->{$arg_name} = shift @$args;
1756 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1758 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1759 if scalar(@$args) != 0;
1762 if (ref($arg_param)) {
1763 foreach my $arg_name (@$arg_param) {
1764 if ($arg_name eq 'extra-args') {
1765 $opts->{'extra-args'} = [];
1766 } elsif (!$schema->{properties
}->{$arg_name}->{optional
}) {
1767 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1773 foreach my $entry (@interactive) {
1774 my ($opt, $func) = @$entry;
1775 my $pd = $schema->{properties
}->{$opt};
1776 my $value = $opts->{$opt};
1777 if (defined($value) || !$pd->{optional
}) {
1778 $opts->{$opt} = $func->($value);
1782 # decode after Getopt as we are not sure how well it handles unicode
1783 foreach my $p (keys %$opts) {
1784 if (!ref($opts->{$p})) {
1785 $opts->{$p} = decode
('locale', $opts->{$p});
1786 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1788 foreach my $v (@{$opts->{$p}}) {
1789 push @$tmp, decode
('locale', $v);
1792 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1793 $opts->{$p} = decode
('locale', $$opts->{$p});
1795 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1799 foreach my $p (keys %$opts) {
1800 if (my $pd = $schema->{properties
}->{$p}) {
1801 if ($pd->{type
} eq 'boolean') {
1802 if ($opts->{$p} eq '') {
1804 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1805 $opts->{$p} = $bool;
1807 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1809 } elsif ($pd->{format
}) {
1811 if ($pd->{format
} =~ m/-list/) {
1812 # allow --vmid 100 --vmid 101 and --vmid 100,101
1813 # allow --dow mon --dow fri and --dow mon,fri
1814 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1815 } elsif ($pd->{format
} =~ m/-alist/) {
1816 # we encode array as \0 separated strings
1817 # Note: CGI.pm also use this encoding
1818 if (scalar(@{$opts->{$p}}) != 1) {
1819 $opts->{$p} = join("\0", @{$opts->{$p}});
1821 # st that split_list knows it is \0 terminated
1822 my $v = $opts->{$p}->[0];
1823 $opts->{$p} = "$v\0";
1830 foreach my $p (keys %$fixed_param) {
1831 $opts->{$p} = $fixed_param->{$p};
1837 # A way to parse configuration data by giving a json schema
1838 sub parse_config
: prototype($$$;$) {
1839 my ($schema, $filename, $raw, $comment_key) = @_;
1841 # do fast check (avoid validate_schema($schema))
1842 die "got strange schema" if !$schema->{type
} ||
1843 !$schema->{properties
} || $schema->{type
} ne 'object';
1848 my $handle_comment = sub { $_[0] =~ /^#/ };
1849 if (defined($comment_key)) {
1851 my $comment_re = qr/^\Q$comment_key\E:\s*(.*\S)\s*$/;
1852 $handle_comment = sub {
1853 if ($_[0] =~ /^\#(.*)\s*$/ || $_[0] =~ $comment_re) {
1854 $comment_data .= PVE
::Tools
::decode_text
($1) . "\n";
1861 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1864 next if $handle_comment->($line);
1866 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1869 if ($schema->{properties
}->{$key} &&
1870 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1872 $value = parse_boolean
($value) // $value;
1875 $schema->{properties
}->{$key}
1876 && $schema->{properties
}->{$key}->{type
} eq 'array'
1879 $cfg->{$key} //= [];
1880 push $cfg->{$key}->@*, $value;
1883 $cfg->{$key} = $value;
1885 warn "ignore config line: $line\n"
1889 if (defined($comment_data)) {
1890 $cfg->{$comment_key} = $comment_data;
1894 check_prop
($cfg, $schema, '', $errors);
1896 foreach my $k (keys %$errors) {
1897 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1904 # generate simple key/value file
1906 my ($schema, $filename, $cfg) = @_;
1908 # do fast check (avoid validate_schema($schema))
1909 die "got strange schema" if !$schema->{type
} ||
1910 !$schema->{properties
} || $schema->{type
} ne 'object';
1912 validate
($cfg, $schema, "validation error in '$filename'\n");
1916 foreach my $k (sort keys %$cfg) {
1917 $data .= "$k: $cfg->{$k}\n";
1923 # helpers used to generate our manual pages
1925 my $find_schema_default_key = sub {
1929 my $keyAliasProps = {};
1931 foreach my $key (keys %$format) {
1932 my $phash = $format->{$key};
1933 if ($phash->{default_key
}) {
1934 die "multiple default keys in schema ($default_key, $key)\n"
1935 if defined($default_key);
1936 die "default key '$key' is an alias - this is not allowed\n"
1937 if defined($phash->{alias
});
1938 die "default key '$key' with keyAlias attribute is not allowed\n"
1939 if $phash->{keyAlias
};
1940 $default_key = $key;
1942 my $key_alias = $phash->{keyAlias
};
1943 die "found keyAlias without 'alias definition for '$key'\n"
1944 if $key_alias && !$phash->{alias
};
1946 if ($phash->{alias
} && $key_alias) {
1947 die "inconsistent keyAlias '$key_alias' definition"
1948 if defined($keyAliasProps->{$key_alias}) &&
1949 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1950 $keyAliasProps->{$key_alias} = $phash->{alias
};
1954 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1957 sub generate_typetext
{
1958 my ($format, $list_enums) = @_;
1960 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1965 my $add_option_string = sub {
1966 my ($text, $optional) = @_;
1972 $text = "[$text]" if $optional;
1977 my $format_key_value = sub {
1978 my ($key, $phash) = @_;
1980 die "internal error" if defined($phash->{alias
});
1986 if (my $desc = $phash->{format_description
}) {
1987 $typetext .= "<$desc>";
1988 } elsif (my $text = $phash->{typetext
}) {
1990 } elsif (my $enum = $phash->{enum
}) {
1991 if ($list_enums || (scalar(@$enum) <= 3)) {
1992 $typetext .= '<' . join('|', @$enum) . '>';
1994 $typetext .= '<enum>';
1996 } elsif ($phash->{type
} eq 'boolean') {
1997 $typetext .= '<1|0>';
1998 } elsif ($phash->{type
} eq 'integer') {
1999 $typetext .= '<integer>';
2000 } elsif ($phash->{type
} eq 'number') {
2001 $typetext .= '<number>';
2003 die "internal error: neither format_description nor typetext found for option '$key'";
2006 if (defined($default_key) && ($default_key eq $key)) {
2007 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
2009 &$add_option_string("$keytext=$typetext", $phash->{optional
});
2015 my $cond_add_key = sub {
2018 return if $done->{$key}; # avoid duplicates
2022 my $phash = $format->{$key};
2024 return if !$phash; # should not happen
2026 return if $phash->{alias
};
2028 &$format_key_value($key, $phash);
2032 &$cond_add_key($default_key) if defined($default_key);
2034 # add required keys first
2035 foreach my $key (sort keys %$format) {
2036 my $phash = $format->{$key};
2037 &$cond_add_key($key) if $phash && !$phash->{optional
};
2041 foreach my $key (sort keys %$format) {
2042 &$cond_add_key($key);
2045 foreach my $keyAlias (sort keys %$keyAliasProps) {
2046 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
2052 sub print_property_string
{
2053 my ($data, $format, $skip, $path) = @_;
2056 if (ref($format) ne 'HASH') {
2057 my $schema = get_format
($format);
2058 die "not a valid format: $format\n" if !$schema;
2059 # named formats can have validators attached
2060 $validator = $format_validators->{$format};
2065 check_object
($path, $format, $data, undef, $errors);
2066 if (scalar(%$errors)) {
2067 raise
"format error", errors
=> $errors;
2070 $data = $validator->($data) if $validator;
2072 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
2077 my $add_option_string = sub {
2080 $res .= ',' if $add_sep;
2085 my $format_value = sub {
2086 my ($key, $value, $format) = @_;
2088 if (defined($format) && ($format eq 'disk-size')) {
2089 return format_size
($value);
2091 die "illegal value with commas for $key\n" if $value =~ /,/;
2096 my $done = { map { $_ => 1 } @$skip };
2098 my $cond_add_key = sub {
2099 my ($key, $isdefault) = @_;
2101 return if $done->{$key}; # avoid duplicates
2105 my $value = $data->{$key};
2107 return if !defined($value);
2109 my $phash = $format->{$key};
2111 # try to combine values if we have key aliases
2112 if (my $combine = $keyAliasProps->{$key}) {
2113 if (defined(my $combine_value = $data->{$combine})) {
2114 my $combine_format = $format->{$combine}->{format
};
2115 my $value_str = &$format_value($key, $value, $phash->{format
});
2116 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
2117 &$add_option_string("${value_str}=${combine_str}");
2118 $done->{$combine} = 1;
2123 if ($phash && $phash->{alias
}) {
2124 $phash = $format->{$phash->{alias
}};
2127 die "invalid key '$key'\n" if !$phash;
2128 die "internal error" if defined($phash->{alias
});
2130 my $value_str = &$format_value($key, $value, $phash->{format
});
2132 &$add_option_string($value_str);
2134 &$add_option_string("$key=${value_str}");
2138 # add default key first
2139 &$cond_add_key($default_key, 1) if defined($default_key);
2141 # add required keys first
2142 foreach my $key (sort keys %$data) {
2143 my $phash = $format->{$key};
2144 &$cond_add_key($key) if $phash && !$phash->{optional
};
2148 foreach my $key (sort keys %$data) {
2149 &$cond_add_key($key);
2155 sub schema_get_type_text
{
2156 my ($phash, $style) = @_;
2158 my $type = $phash->{type
} || 'string';
2160 if ($phash->{typetext
}) {
2161 return $phash->{typetext
};
2162 } elsif ($phash->{format_description
}) {
2163 return "<$phash->{format_description}>";
2164 } elsif ($phash->{enum
}) {
2165 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
2166 } elsif ($phash->{pattern
}) {
2167 return $phash->{pattern
};
2168 } elsif ($type eq 'integer' || $type eq 'number') {
2169 # NOTE: always access values as number (avoid converion to string)
2170 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
2171 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
2172 ($phash->{maximum
} + 0) . ")";
2173 } elsif (defined($phash->{minimum
})) {
2174 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
2175 } elsif (defined($phash->{maximum
})) {
2176 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
2178 } elsif ($type eq 'string') {
2179 if (my $format = $phash->{format
}) {
2180 $format = get_format
($format) if ref($format) ne 'HASH';
2181 if (ref($format) eq 'HASH') {
2183 $list_enums = 1 if $style && $style eq 'config-sub';
2184 return generate_typetext
($format, $list_enums);