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);
14 use Net
::IP
qw(:PROC);
20 register_standard_option
26 our $CONFIGID_RE = qr/[a-z][a-z0-9_-]+/i;
28 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
29 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
30 # see: http://json-schema.org/
32 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
34 my $standard_options = {};
35 sub register_standard_option
{
36 my ($name, $schema) = @_;
38 die "standard option '$name' already registered\n"
39 if $standard_options->{$name};
41 $standard_options->{$name} = $schema;
44 sub get_standard_option
{
45 my ($name, $base) = @_;
47 my $std = $standard_options->{$name};
48 die "no such standard option '$name'\n" if !$std;
50 my $res = $base || {};
52 foreach my $opt (keys %$std) {
53 next if defined($res->{$opt});
54 $res->{$opt} = $std->{$opt};
60 register_standard_option
('pve-vmid', {
61 description
=> "The (unique) ID of the VM.",
65 maximum
=> 999_999_999,
68 register_standard_option
('pve-node', {
69 description
=> "The cluster node name.",
70 type
=> 'string', format
=> 'pve-node',
73 register_standard_option
('pve-node-list', {
74 description
=> "List of cluster node names.",
75 type
=> 'string', format
=> 'pve-node-list',
78 register_standard_option
('pve-iface', {
79 description
=> "Network interface name.",
80 type
=> 'string', format
=> 'pve-iface',
81 minLength
=> 2, maxLength
=> 20,
84 register_standard_option
('pve-storage-id', {
85 description
=> "The storage identifier.",
86 type
=> 'string', format
=> 'pve-storage-id',
89 register_standard_option
('pve-bridge-id', {
90 description
=> "Bridge to attach guest network devices to.",
91 type
=> 'string', format
=> 'pve-bridge-id',
92 format_description
=> 'bridge',
95 register_standard_option
('pve-config-digest', {
96 description
=> 'Prevent changes if current configuration file has a different digest. '
97 . 'This can be used to prevent concurrent modifications.',
100 # sha1 hex digests are 40 characters long
101 # sha256 hex digests are 64 characters long (sha256 is used in our Rust code)
105 register_standard_option
('skiplock', {
106 description
=> "Ignore locks - only root is allowed to use this option.",
111 register_standard_option
('extra-args', {
112 description
=> "Extra arguments as array",
114 items
=> { type
=> 'string' },
118 register_standard_option
('fingerprint-sha256', {
119 description
=> "Certificate SHA 256 fingerprint.",
121 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
124 register_standard_option
('pve-output-format', {
126 description
=> 'Output format.',
127 enum
=> [ 'text', 'json', 'json-pretty', 'yaml' ],
132 register_standard_option
('pve-snapshot-name', {
133 description
=> "The name of the snapshot.",
134 type
=> 'string', format
=> 'pve-configid',
138 my $format_list = {};
139 my $format_validators = {};
141 sub register_format
{
142 my ($name, $format, $validator) = @_;
144 die "JSON schema format '$name' already registered\n"
145 if $format_list->{$name};
148 die "A \$validator function can only be specified for hash-based formats\n"
149 if ref($format) ne 'HASH';
150 $format_validators->{$name} = $validator;
153 $format_list->{$name} = $format;
158 return $format_list->{$name};
161 my $renderer_hash = {};
163 sub register_renderer
{
164 my ($name, $code) = @_;
166 die "renderer '$name' already registered\n"
167 if $renderer_hash->{$name};
169 $renderer_hash->{$name} = $code;
174 return $renderer_hash->{$name};
177 # register some common type for pve
179 register_format
('string', sub {}); # allow format => 'string-list'
181 register_format
('urlencoded', \
&pve_verify_urlencoded
);
182 sub pve_verify_urlencoded
{
183 my ($text, $noerr) = @_;
184 if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
185 return undef if $noerr;
186 die "invalid urlencoded string: $text\n";
191 register_format
('pve-configid', \
&pve_verify_configid
);
192 sub pve_verify_configid
{
193 my ($id, $noerr) = @_;
195 if ($id !~ m/^$CONFIGID_RE$/) {
196 return undef if $noerr;
197 die "invalid configuration ID '$id'\n";
202 PVE
::JSONSchema
::register_format
('pve-storage-id', \
&parse_storage_id
);
203 sub parse_storage_id
{
204 my ($storeid, $noerr) = @_;
206 return parse_id
($storeid, 'storage', $noerr);
209 PVE
::JSONSchema
::register_format
('pve-bridge-id', \
&parse_bridge_id
);
210 sub parse_bridge_id
{
211 my ($id, $noerr) = @_;
213 if ($id !~ m/^[-_.\w\d]+$/) {
214 return undef if $noerr;
215 die "invalid bridge ID '$id'\n";
220 PVE
::JSONSchema
::register_format
('acme-plugin-id', \
&parse_acme_plugin_id
);
221 sub parse_acme_plugin_id
{
222 my ($pluginid, $noerr) = @_;
224 return parse_id
($pluginid, 'ACME plugin', $noerr);
228 my ($id, $type, $noerr) = @_;
230 if ($id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
231 return undef if $noerr;
232 die "$type ID '$id' contains illegal characters\n";
237 register_format
('pve-vmid', \
&pve_verify_vmid
);
238 sub pve_verify_vmid
{
239 my ($vmid, $noerr) = @_;
241 if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
242 return undef if $noerr;
243 die "value does not look like a valid VM ID\n";
248 register_format
('pve-node', \
&pve_verify_node_name
);
249 sub pve_verify_node_name
{
250 my ($node, $noerr) = @_;
252 if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
253 return undef if $noerr;
254 die "value does not look like a valid node name\n";
259 # maps source to target ID using an ID map
261 my ($map, $source) = @_;
263 return $source if !defined($map);
265 return $map->{entries
}->{$source}
266 if $map->{entries
} && defined($map->{entries
}->{$source});
268 return $map->{default} if $map->{default};
270 # identity (fallback)
275 my ($idmap, $idformat) = @_;
277 return undef if !$idmap;
281 foreach my $entry (PVE
::Tools
::split_list
($idmap)) {
283 $map->{identity
} = 1;
284 } elsif ($entry =~ m/^([^:]+):([^:]+)$/) {
285 my ($source, $target) = ($1, $2);
287 check_format
($idformat, $source, '');
288 check_format
($idformat, $target, '');
290 die "entry '$entry' contains invalid ID - $@\n" if $@;
292 die "duplicate mapping for source '$source'\n"
293 if exists $map->{entries
}->{$source};
295 $map->{entries
}->{$source} = $target;
298 check_format
($idformat, $entry);
300 die "entry '$entry' contains invalid ID - $@\n" if $@;
302 die "default target ID can only be provided once\n"
303 if exists $map->{default};
305 $map->{default} = $entry;
309 die "identity mapping cannot be combined with other mappings\n"
310 if $map->{identity
} && ($map->{default} || exists $map->{entries
});
315 my $verify_idpair = sub {
316 my ($input, $noerr, $format) = @_;
318 eval { parse_idmap
($input, $format) };
320 return undef if $noerr;
327 PVE
::JSONSchema
::register_standard_option
('pve-targetstorage', {
328 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.",
330 format
=> 'storage-pair-list',
334 # note: this only checks a single list entry
335 # when using a storage-pair-list map, you need to pass the full parameter to
337 register_format
('storage-pair', \
&verify_storagepair
);
338 sub verify_storagepair
{
339 my ($storagepair, $noerr) = @_;
340 return $verify_idpair->($storagepair, $noerr, 'pve-storage-id');
343 # note: this only checks a single list entry
344 # when using a bridge-pair-list map, you need to pass the full parameter to
346 register_format
('bridge-pair', \
&verify_bridgepair
);
347 sub verify_bridgepair
{
348 my ($bridgepair, $noerr) = @_;
349 return $verify_idpair->($bridgepair, $noerr, 'pve-bridge-id');
352 register_format
('mac-addr', \
&pve_verify_mac_addr
);
353 sub pve_verify_mac_addr
{
354 my ($mac_addr, $noerr) = @_;
356 # don't allow I/G bit to be set, most of the time it breaks things, see:
357 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
358 if ($mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i) {
359 return undef if $noerr;
360 die "value does not look like a valid unicast MAC address\n";
365 register_standard_option
('mac-addr', {
367 description
=> 'Unicast MAC address.',
368 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.',
369 format_description
=> "XX:XX:XX:XX:XX:XX",
371 format
=> 'mac-addr',
374 register_format
('ipv4', \
&pve_verify_ipv4
);
375 sub pve_verify_ipv4
{
376 my ($ipv4, $noerr) = @_;
378 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
379 return undef if $noerr;
380 die "value does not look like a valid IPv4 address\n";
385 register_format
('ipv6', \
&pve_verify_ipv6
);
386 sub pve_verify_ipv6
{
387 my ($ipv6, $noerr) = @_;
389 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
390 return undef if $noerr;
391 die "value does not look like a valid IPv6 address\n";
396 register_format
('ip', \
&pve_verify_ip
);
398 my ($ip, $noerr) = @_;
400 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
401 return undef if $noerr;
402 die "value does not look like a valid IP address\n";
407 PVE
::JSONSchema
::register_format
('ldap-simple-attr', \
&verify_ldap_simple_attr
);
408 sub verify_ldap_simple_attr
{
409 my ($attr, $noerr) = @_;
411 if ($attr =~ m/^[a-zA-Z0-9]+$/) {
415 die "value '$attr' does not look like a simple ldap attribute name\n" if !$noerr;
420 my $ipv4_mask_hash = {
438 '255.255.128.0' => 17,
439 '255.255.192.0' => 18,
440 '255.255.224.0' => 19,
441 '255.255.240.0' => 20,
442 '255.255.248.0' => 21,
443 '255.255.252.0' => 22,
444 '255.255.254.0' => 23,
445 '255.255.255.0' => 24,
446 '255.255.255.128' => 25,
447 '255.255.255.192' => 26,
448 '255.255.255.224' => 27,
449 '255.255.255.240' => 28,
450 '255.255.255.248' => 29,
451 '255.255.255.252' => 30,
452 '255.255.255.254' => 31,
453 '255.255.255.255' => 32,
456 sub get_netmask_bits
{
458 return $ipv4_mask_hash->{$mask};
461 register_format
('ipv4mask', \
&pve_verify_ipv4mask
);
462 sub pve_verify_ipv4mask
{
463 my ($mask, $noerr) = @_;
465 if (!defined($ipv4_mask_hash->{$mask})) {
466 return undef if $noerr;
467 die "value does not look like a valid IP netmask\n";
472 register_format
('CIDRv6', \
&pve_verify_cidrv6
);
473 sub pve_verify_cidrv6
{
474 my ($cidr, $noerr) = @_;
476 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
480 return undef if $noerr;
481 die "value does not look like a valid IPv6 CIDR network\n";
484 register_format
('CIDRv4', \
&pve_verify_cidrv4
);
485 sub pve_verify_cidrv4
{
486 my ($cidr, $noerr) = @_;
488 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
492 return undef if $noerr;
493 die "value does not look like a valid IPv4 CIDR network\n";
496 register_format
('CIDR', \
&pve_verify_cidr
);
497 sub pve_verify_cidr
{
498 my ($cidr, $noerr) = @_;
500 if (!(pve_verify_cidrv4
($cidr, 1) ||
501 pve_verify_cidrv6
($cidr, 1)))
503 return undef if $noerr;
504 die "value does not look like a valid CIDR network\n";
510 register_format
('pve-ipv4-config', \
&pve_verify_ipv4_config
);
511 sub pve_verify_ipv4_config
{
512 my ($config, $noerr) = @_;
514 return $config if $config =~ /^(?:dhcp|manual)$/ ||
515 pve_verify_cidrv4
($config, 1);
516 return undef if $noerr;
517 die "value does not look like a valid ipv4 network configuration\n";
520 register_format
('pve-ipv6-config', \
&pve_verify_ipv6_config
);
521 sub pve_verify_ipv6_config
{
522 my ($config, $noerr) = @_;
524 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
525 pve_verify_cidrv6
($config, 1);
526 return undef if $noerr;
527 die "value does not look like a valid ipv6 network configuration\n";
530 register_format
('email', \
&pve_verify_email
);
531 sub pve_verify_email
{
532 my ($email, $noerr) = @_;
534 if ($email !~ /^$PVE::Tools::EMAIL_RE$/) {
535 return undef if $noerr;
536 die "value does not look like a valid email address\n";
541 register_format
('email-or-username', \
&pve_verify_email_or_username
);
542 sub pve_verify_email_or_username
{
543 my ($email, $noerr) = @_;
545 if ($email !~ /^$PVE::Tools::EMAIL_RE$/ &&
546 $email !~ /^$PVE::Tools::EMAIL_USER_RE$/) {
547 return undef if $noerr;
548 die "value does not look like a valid email address or user name\n";
553 register_format
('dns-name', \
&pve_verify_dns_name
);
554 sub pve_verify_dns_name
{
555 my ($name, $noerr) = @_;
557 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
559 if ($name !~ /^(${namere}\.)*${namere}$/) {
560 return undef if $noerr;
561 die "value does not look like a valid DNS name\n";
566 register_format
('timezone', \
&pve_verify_timezone
);
567 sub pve_verify_timezone
{
568 my ($timezone, $noerr) = @_;
570 return $timezone if $timezone eq 'UTC';
572 open(my $fh, "<", "/usr/share/zoneinfo/zone.tab");
573 while (my $line = <$fh>) {
574 next if $line =~ /^\s*#/;
576 my $zone = (split /\t/, $line)[2];
577 return $timezone if $timezone eq $zone; # found
581 return undef if $noerr;
582 die "invalid time zone '$timezone'\n";
585 # network interface name
586 register_format
('pve-iface', \
&pve_verify_iface
);
587 sub pve_verify_iface
{
588 my ($id, $noerr) = @_;
590 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
591 return undef if $noerr;
592 die "invalid network interface name '$id'\n";
597 # general addresses by name or IP
598 register_format
('address', \
&pve_verify_address
);
599 sub pve_verify_address
{
600 my ($addr, $noerr) = @_;
602 if (!(pve_verify_ip
($addr, 1) ||
603 pve_verify_dns_name
($addr, 1)))
605 return undef if $noerr;
606 die "value does not look like a valid address: $addr\n";
611 register_format
('disk-size', \
&pve_verify_disk_size
);
612 sub pve_verify_disk_size
{
613 my ($size, $noerr) = @_;
614 if (!defined(parse_size
($size))) {
615 return undef if $noerr;
616 die "value does not look like a valid disk size: $size\n";
621 register_standard_option
('spice-proxy', {
622 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).",
623 type
=> 'string', format
=> 'address',
626 register_standard_option
('remote-viewer-config', {
627 description
=> "Returned values can be directly passed to the 'remote-viewer' application.",
628 additionalProperties
=> 1,
630 type
=> { type
=> 'string' },
631 password
=> { type
=> 'string' },
632 proxy
=> { type
=> 'string' },
633 host
=> { type
=> 'string' },
634 'tls-port' => { type
=> 'integer' },
638 register_format
('pve-startup-order', \
&pve_verify_startup_order
);
639 sub pve_verify_startup_order
{
640 my ($value, $noerr) = @_;
642 return $value if pve_parse_startup_order
($value);
644 return undef if $noerr;
646 die "unable to parse startup options\n";
651 type
=> 'number', minimum
=> '0',
652 format_description
=> 'LIMIT',
655 my $bwlimit_format = {
658 description
=> 'default bandwidth limit in KiB/s',
662 description
=> 'bandwidth limit in KiB/s for restoring guests from backups',
666 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)',
670 description
=> 'bandwidth limit in KiB/s for cloning disks',
674 description
=> 'bandwidth limit in KiB/s for moving disks',
677 register_format
('bwlimit', $bwlimit_format);
678 register_standard_option
('bwlimit', {
679 description
=> "Set I/O bandwidth limit for various operations (in KiB/s).",
682 format
=> $bwlimit_format,
685 my $remote_format = {
688 format_description
=> 'Remote Proxmox hostname or IP',
696 format_description
=> 'A full Proxmox API token including the secret value.',
698 fingerprint
=> get_standard_option
(
699 'fingerprint-sha256',
702 format_description
=> 'Remote host\'s certificate fingerprint, if not trusted by system store.',
706 register_format
('proxmox-remote', $remote_format);
707 register_standard_option
('proxmox-remote', {
708 description
=> "Specification of a remote endpoint.",
709 type
=> 'string', format
=> 'proxmox-remote',
712 our $PVE_TAG_RE = qr/[a-z0-9_][a-z0-9_\-\+\.]*/i;
714 # used for pve-tag-list in e.g., guest configs
715 register_format
('pve-tag', \
&pve_verify_tag
);
717 my ($value, $noerr) = @_;
719 return $value if $value =~ m/^${PVE_TAG_RE}$/i;
721 return undef if $noerr;
723 die "invalid characters in tag\n";
726 sub pve_parse_startup_order
{
729 return undef if !$value;
733 foreach my $p (split(/,/, $value)) {
734 next if $p =~ m/^\s*$/;
736 if ($p =~ m/^(order=)?(\d+)$/) {
738 } elsif ($p =~ m/^up=(\d+)$/) {
740 } elsif ($p =~ m/^down=(\d+)$/) {
750 PVE
::JSONSchema
::register_standard_option
('pve-startup-order', {
751 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.",
753 type
=> 'string', format
=> 'pve-startup-order',
754 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ',
757 register_format
('pve-tfa-secret', \
&pve_verify_tfa_secret
);
758 sub pve_verify_tfa_secret
{
759 my ($key, $noerr) = @_;
761 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
762 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
763 # format to support arbitrary lengths properly:
764 if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
765 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
766 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
771 return undef if $noerr;
773 die "unable to decode TFA secret\n";
777 PVE
::JSONSchema
::register_format
('pve-task-status-type', \
&verify_task_status_type
);
778 sub verify_task_status_type
{
779 my ($value, $noerr) = @_;
781 return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
783 return undef if $noerr;
785 die "invalid status '$value'\n";
789 my ($format, $value, $path) = @_;
791 if (ref($format) eq 'HASH') {
792 # hash ref cannot have validator/list/opt handling attached
793 return parse_property_string
($format, $value, $path);
796 if (ref($format) eq 'CODE') {
797 # we are the (sole, old-style) validator
798 return $format->($value);
801 return if $format eq 'regex';
804 $format =~ m/^(.*?)(?:-(list|opt))?$/;
805 my ($format_name, $format_type) = ($1, $2 // 'none');
806 my $registered = get_format
($format_name);
807 die "undefined format '$format'\n" if !$registered;
809 die "'-$format_type' format must have code ref, not hash\n"
810 if $format_type ne 'none' && ref($registered) ne 'CODE';
812 if ($format_type eq 'list') {
814 # Note: we allow empty lists
815 foreach my $v (split_list
($value)) {
816 push @{$parsed}, $registered->($v);
818 } elsif ($format_type eq 'opt') {
819 $parsed = $registered->($value) if $value;
821 if (ref($registered) eq 'HASH') {
822 # Note: this is the only case where a validator function could be
823 # attached, hence it's safe to handle that in parse_property_string.
824 # We do however have to call it with $format_name instead of
825 # $registered, so it knows about the name (and thus any validators).
826 $parsed = parse_property_string
($format, $value, $path);
828 $parsed = $registered->($value);
838 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
839 my ($size, $unit) = ($1, $3);
842 $size = $size * 1024;
843 } elsif ($unit eq 'M') {
844 $size = $size * 1024 * 1024;
845 } elsif ($unit eq 'G') {
846 $size = $size * 1024 * 1024 * 1024;
847 } elsif ($unit eq 'T') {
848 $size = $size * 1024 * 1024 * 1024 * 1024;
859 my $kb = int($size/1024);
860 return $size if $kb*1024 != $size;
862 my $mb = int($kb/1024);
863 return "${kb}K" if $mb*1024 != $kb;
865 my $gb = int($mb/1024);
866 return "${mb}M" if $gb*1024 != $mb;
868 my $tb = int($gb/1024);
869 return "${gb}G" if $tb*1024 != $gb;
876 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
877 return 0 if $bool =~ m/^(0|off|no|false)$/i;
881 sub parse_property_string
{
882 my ($format, $data, $path, $additional_properties) = @_;
884 # In property strings we default to not allowing additional properties
885 $additional_properties = 0 if !defined($additional_properties);
887 # Support named formats here, too:
890 if (my $reg = get_format
($format)) {
891 die "parse_property_string only accepts hash based named formats\n"
892 if ref($reg) ne 'HASH';
894 # named formats can have validators attached
895 $validator = $format_validators->{$format};
899 die "unknown format: $format\n";
901 } elsif (ref($format) ne 'HASH') {
902 die "unexpected format value of type ".ref($format)."\n";
908 foreach my $part (split(/,/, $data)) {
909 next if $part =~ /^\s*$/;
911 if ($part =~ /^([^=]+)=(.+)$/) {
912 my ($k, $v) = ($1, $2);
913 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
914 my $schema = $format->{$k};
915 if (my $alias = $schema->{alias
}) {
916 if (my $key_alias = $schema->{keyAlias
}) {
917 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
918 $res->{$key_alias} = $k;
921 $schema = $format->{$k};
924 die "invalid key in comma-separated list property: $k\n" if !$schema;
925 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
926 $v = parse_boolean
($v) // $v;
929 } elsif ($part !~ /=/) {
930 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
931 foreach my $key (keys %$format) {
932 if ($format->{$key}->{default_key
}) {
934 if (!$res->{$default_key}) {
935 $res->{$default_key} = $part;
938 die "duplicate key in comma-separated list property: $default_key\n";
941 die "value without key, but schema does not define a default key\n" if !$default_key;
943 die "missing key in comma-separated list property\n";
948 check_object
($path, $format, $res, $additional_properties, $errors);
949 if (scalar(%$errors)) {
950 raise
"format error\n", errors
=> $errors;
953 return $validator->($res) if $validator;
958 my ($errors, $path, $msg) = @_;
960 $path = '_root' if !$path;
962 if ($errors->{$path}) {
963 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
965 $errors->{$path} = $msg;
972 # see 'man perlretut'
973 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
979 return $value =~ m/^[+-]?\d+$/;
983 my ($path, $type, $value, $errors) = @_;
987 if (!defined($value)) {
988 return 1 if $type eq 'null';
992 if (my $tt = ref($type)) {
993 if ($tt eq 'ARRAY') {
994 foreach my $t (@$type) {
996 check_type
($path, $t, $value, $tmperr);
997 return 1 if !scalar(%$tmperr);
999 my $ttext = join ('|', @$type);
1000 add_error
($errors, $path, "type check ('$ttext') failed");
1002 } elsif ($tt eq 'HASH') {
1004 check_prop
($value, $type, $path, $tmperr);
1005 return 1 if !scalar(%$tmperr);
1006 add_error
($errors, $path, "type check failed");
1009 die "internal error - got reference type '$tt'";
1014 return 1 if $type eq 'any';
1016 if ($type eq 'null') {
1017 if (defined($value)) {
1018 add_error
($errors, $path, "type check ('$type') failed - value is not null");
1024 my $vt = ref($value);
1026 if ($type eq 'array') {
1027 if (!$vt || $vt ne 'ARRAY') {
1028 add_error
($errors, $path, "type check ('$type') failed");
1032 } elsif ($type eq 'object') {
1033 if (!$vt || $vt ne 'HASH') {
1034 add_error
($errors, $path, "type check ('$type') failed");
1038 } elsif ($type eq 'coderef') {
1039 if (!$vt || $vt ne 'CODE') {
1040 add_error
($errors, $path, "type check ('$type') failed");
1044 } elsif ($type eq 'string' && $vt eq 'Regexp') {
1045 # qr// regexes can be used as strings and make sense for format=regex
1049 if ($type eq 'boolean' && JSON
::is_bool
($value)) {
1052 add_error
($errors, $path, "type check ('$type') failed - got $vt");
1055 if ($type eq 'string') {
1056 return 1; # nothing to check ?
1057 } elsif ($type eq 'boolean') {
1058 #if ($value =~ m/^(1|true|yes|on)$/i) {
1059 if ($value eq '1') {
1061 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
1062 } elsif ($value eq '0') {
1063 return 1; # return success (not value)
1065 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1068 } elsif ($type eq 'integer') {
1069 if (!is_integer
($value)) {
1070 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1074 } elsif ($type eq 'number') {
1075 if (!is_number
($value)) {
1076 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1081 return 1; # no need to verify unknown types
1091 my ($path, $schema, $value, $additional_properties, $errors) = @_;
1093 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
1095 my $st = ref($schema);
1096 if (!$st || $st ne 'HASH') {
1097 add_error
($errors, $path, "Invalid schema definition.");
1101 my $vt = ref($value);
1102 if (!$vt || $vt ne 'HASH') {
1103 add_error
($errors, $path, "an object is required");
1107 foreach my $k (keys %$schema) {
1108 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
1111 foreach my $k (keys %$value) {
1113 my $newpath = $path ?
"$path.$k" : $k;
1115 if (my $subschema = $schema->{$k}) {
1116 if (my $requires = $subschema->{requires
}) {
1117 if (ref($requires)) {
1118 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1119 check_prop
($value, $requires, $path, $errors);
1120 } elsif (!defined($value->{$requires})) {
1121 add_error
($errors, $path ?
"$path.$requires" : $requires,
1122 "missing property - '$newpath' requires this property");
1126 next; # value is already checked above
1129 if (defined ($additional_properties) && !$additional_properties) {
1130 add_error
($errors, $newpath, "property is not defined in schema " .
1131 "and the schema does not allow additional properties");
1134 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
1135 if ref($additional_properties);
1139 sub check_object_warn
{
1140 my ($path, $schema, $value, $additional_properties) = @_;
1142 check_object
($path, $schema, $value, $additional_properties, $errors);
1143 if (scalar(%$errors)) {
1144 foreach my $k (keys %$errors) {
1145 warn "parse error: $k: $errors->{$k}\n";
1153 my ($value, $schema, $path, $errors) = @_;
1155 die "internal error - no schema" if !$schema;
1156 die "internal error" if !$errors;
1158 #print "check_prop $path\n" if $value;
1160 my $st = ref($schema);
1161 if (!$st || $st ne 'HASH') {
1162 add_error
($errors, $path, "Invalid schema definition.");
1166 # if it extends another schema, it must pass that schema as well
1167 if($schema->{extends
}) {
1168 check_prop
($value, $schema->{extends
}, $path, $errors);
1171 if (!defined ($value)) {
1172 return if $schema->{type
} && $schema->{type
} eq 'null';
1173 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
1174 add_error
($errors, $path, "property is missing and it is not optional");
1179 return if !check_type
($path, $schema->{type
}, $value, $errors);
1181 if ($schema->{disallow
}) {
1183 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
1184 add_error
($errors, $path, "disallowed value was matched");
1189 if (my $vt = ref($value)) {
1191 if ($vt eq 'ARRAY') {
1192 if ($schema->{items
}) {
1193 my $it = ref($schema->{items
});
1194 if ($it && $it eq 'ARRAY') {
1195 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1196 die "not implemented";
1199 foreach my $el (@$value) {
1200 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
1206 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
1207 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
1208 $value, $schema->{additionalProperties
}, $errors);
1214 if (my $format = $schema->{format
}) {
1215 eval { check_format
($format, $value, $path); };
1217 add_error
($errors, $path, "invalid format - $@");
1222 if (my $pattern = $schema->{pattern
}) {
1223 if ($value !~ m/^$pattern$/) {
1224 add_error
($errors, $path, "value does not match the regex pattern");
1229 if (defined (my $max = $schema->{maxLength
})) {
1230 if (length($value) > $max) {
1231 add_error
($errors, $path, "value may only be $max characters long");
1236 if (defined (my $min = $schema->{minLength
})) {
1237 if (length($value) < $min) {
1238 add_error
($errors, $path, "value must be at least $min characters long");
1243 if (is_number
($value)) {
1244 if (defined (my $max = $schema->{maximum
})) {
1245 if ($value > $max) {
1246 add_error
($errors, $path, "value must have a maximum value of $max");
1251 if (defined (my $min = $schema->{minimum
})) {
1252 if ($value < $min) {
1253 add_error
($errors, $path, "value must have a minimum value of $min");
1259 if (my $ea = $schema->{enum
}) {
1262 foreach my $ev (@$ea) {
1263 if ($ev eq $value) {
1269 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
1270 join(", ", @$ea) . "'");
1277 my ($instance, $schema, $errmsg) = @_;
1280 $errmsg = "Parameter verification failed.\n" if !$errmsg;
1282 # todo: cycle detection is only needed for debugging, I guess
1283 # we can disable that in the final release
1284 # todo: is there a better/faster way to detect cycles?
1286 # 'download' responses can contain a filehandle, don't cycle-check that as
1287 # it produces a warning
1288 my $is_download = ref($instance) eq 'HASH' && exists($instance->{download
});
1289 find_cycle
($instance, sub { $cycles = 1 }) if !$is_download;
1291 add_error
($errors, undef, "data structure contains recursive cycles");
1293 check_prop
($instance, $schema, '', $errors);
1296 if (scalar(%$errors)) {
1297 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1303 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1304 my $default_schema_noref = {
1305 description
=> "This is the JSON Schema for JSON Schemas.",
1306 type
=> [ "object" ],
1307 additionalProperties
=> 0,
1310 type
=> ["string", "array"],
1311 description
=> "This is a type definition value. This can be a simple type, or a union type",
1316 enum
=> $schema_valid_types,
1318 enum
=> $schema_valid_types,
1322 description
=> "This indicates that the instance property in the instance object is not required.",
1328 description
=> "This is a definition for the properties of an object value",
1334 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1338 additionalProperties
=> {
1339 type
=> [ "boolean", "object"],
1340 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1347 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1352 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1356 description
=> "When the instance value is a string, this indicates minimum length of the string",
1363 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1369 description
=> "A text representation of the type (used to generate documentation).",
1374 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.",
1381 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1386 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).",
1388 verbose_description
=> {
1391 description
=> "This provides a more verbose description.",
1393 format_description
=> {
1396 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1401 description
=> "This provides the title of the property",
1406 description
=> "This is used to provide rendering hints to format cli command output.",
1409 type
=> [ "string", "object" ],
1411 description
=> "indicates a required property or a schema that must be validated if this property is present",
1414 type
=> [ "string", "object" ],
1416 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",
1421 description
=> "Whether this is the default key in a comma separated list property string.",
1426 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.",
1431 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1432 requires
=> 'alias',
1437 description
=> "This indicates the default for the instance property."
1441 description
=> "Bash completion function. This function should return a list of possible values.",
1447 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.",
1452 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1455 # this is from hyper schema
1458 description
=> "This defines the link relations of the instance objects",
1465 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",
1469 description
=> "This is the name of the link relation",
1475 description
=> "For submission links, this defines the method that should be used to access the target resource",
1484 description
=> "For CLI context, this defines the maximal width to print before truncating",
1490 my $default_schema = Storable
::dclone
($default_schema_noref);
1492 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1493 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1495 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1496 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1498 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1499 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1501 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1502 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1504 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1505 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1507 my $method_schema = {
1509 additionalProperties
=> 0,
1512 description
=> "This a description of the method",
1517 description
=> "This indicates the name of the function to call.",
1520 additionalProperties
=> 1,
1535 description
=> "The HTTP method name.",
1536 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1541 description
=> "Method needs special privileges - only pvedaemon can execute it",
1546 description
=> "Method is available for clients authenticated using an API token.",
1552 description
=> "Method downloads the file content (filename is the return value of the method).",
1557 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1560 proxyto_callback
=> {
1562 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1567 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1569 additionalProperties
=> 0,
1572 description
=> "Describe access permissions.",
1576 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1578 enum
=> ['all', 'world'],
1582 description
=> "Array of permission checks (prefix notation).",
1589 description
=> "Used internally",
1593 description
=> "Used internally",
1598 description
=> "path for URL matching (uri template)",
1600 fragmentDelimiter
=> {
1602 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.",
1607 description
=> "JSON Schema for parameters.",
1612 description
=> "JSON Schema for return value.",
1617 description
=> "method implementation (code reference)",
1622 description
=> "Delegate call to this class (perl class string).",
1625 additionalProperties
=> 0,
1631 fragmentDelimiter
=> { optional
=> 1 }
1639 sub validate_schema
{
1642 my $errmsg = "internal error - unable to verify schema\n";
1643 validate
($schema, $default_schema, $errmsg);
1646 sub validate_method_info
{
1649 my $errmsg = "internal error - unable to verify method info\n";
1650 validate
($info, $method_schema, $errmsg);
1652 validate_schema
($info->{parameters
}) if $info->{parameters
};
1653 validate_schema
($info->{returns
}) if $info->{returns
};
1656 # run a self test on load
1657 # make sure we can verify the default schema
1658 validate_schema
($default_schema_noref);
1659 validate_schema
($method_schema);
1661 # and now some utility methods (used by pve api)
1662 sub method_get_child_link
{
1665 return undef if !$info;
1667 my $schema = $info->{returns
};
1668 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1670 my $links = $schema->{links
};
1671 return undef if !$links;
1674 foreach my $lnk (@$links) {
1675 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1684 # a way to parse command line parameters, using a
1685 # schema to configure Getopt::Long
1687 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1689 if (!$schema || !$schema->{properties
}) {
1690 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1691 if scalar(@$args) != 0;
1696 if ($arg_param && !ref($arg_param)) {
1697 my $pd = $schema->{properties
}->{$arg_param};
1698 die "expected list format $pd->{format}"
1699 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1700 $list_param = $arg_param;
1703 my @interactive = ();
1705 foreach my $prop (keys %{$schema->{properties
}}) {
1706 my $pd = $schema->{properties
}->{$prop};
1707 next if $list_param && $prop eq $list_param;
1708 next if defined($fixed_param->{$prop});
1710 my $mapping = $param_mapping_hash->{$prop};
1711 if ($mapping && $mapping->{interactive
}) {
1712 # interactive parameters such as passwords: make the argument
1713 # optional and call the mapping function afterwards.
1714 push @getopt, "$prop:s";
1715 push @interactive, [$prop, $mapping->{func
}];
1716 } elsif ($pd->{type
} eq 'boolean') {
1717 push @getopt, "$prop:s";
1719 if ($pd->{format
} && $pd->{format
} =~ m/-list/) {
1720 push @getopt, "$prop=s@";
1721 } elsif ($pd->{type
} eq 'array') {
1722 push @getopt, "$prop=s@";
1724 push @getopt, "$prop=s";
1729 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1732 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1733 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1737 $opts->{$list_param} = $args;
1739 } elsif (ref($arg_param)) {
1740 for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1741 my $arg_name = $arg_param->[$i];
1742 if ($opts->{'extra-args'}) {
1743 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1745 if ($arg_name eq 'extra-args') {
1746 $opts->{'extra-args'} = $args;
1751 # check if all left-over arg_param are optional, else we
1752 # must die as the mapping is then ambigious
1753 for (; $i < scalar(@$arg_param); $i++) {
1754 my $prop = $arg_param->[$i];
1755 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
)
1756 if !$schema->{properties
}->{$prop}->{optional
};
1758 if ($arg_param->[-1] eq 'extra-args') {
1759 $opts->{'extra-args'} = [];
1763 $opts->{$arg_name} = shift @$args;
1765 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1767 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1768 if scalar(@$args) != 0;
1771 if (ref($arg_param)) {
1772 foreach my $arg_name (@$arg_param) {
1773 if ($arg_name eq 'extra-args') {
1774 $opts->{'extra-args'} = [];
1775 } elsif (!$schema->{properties
}->{$arg_name}->{optional
}) {
1776 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1782 foreach my $entry (@interactive) {
1783 my ($opt, $func) = @$entry;
1784 my $pd = $schema->{properties
}->{$opt};
1785 my $value = $opts->{$opt};
1786 if (defined($value) || !$pd->{optional
}) {
1787 $opts->{$opt} = $func->($value);
1791 # decode after Getopt as we are not sure how well it handles unicode
1792 foreach my $p (keys %$opts) {
1793 if (!ref($opts->{$p})) {
1794 $opts->{$p} = decode
('locale', $opts->{$p});
1795 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1797 foreach my $v (@{$opts->{$p}}) {
1798 push @$tmp, decode
('locale', $v);
1801 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1802 $opts->{$p} = decode
('locale', $$opts->{$p});
1804 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1808 foreach my $p (keys %$opts) {
1809 if (my $pd = $schema->{properties
}->{$p}) {
1810 if ($pd->{type
} eq 'boolean') {
1811 if ($opts->{$p} eq '') {
1813 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1814 $opts->{$p} = $bool;
1816 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1818 } elsif ($pd->{format
}) {
1820 if ($pd->{format
} =~ m/-list/) {
1821 # allow --vmid 100 --vmid 101 and --vmid 100,101
1822 # allow --dow mon --dow fri and --dow mon,fri
1823 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1829 foreach my $p (keys %$fixed_param) {
1830 $opts->{$p} = $fixed_param->{$p};
1836 # A way to parse configuration data by giving a json schema
1837 sub parse_config
: prototype($$$;$) {
1838 my ($schema, $filename, $raw, $comment_key) = @_;
1840 # do fast check (avoid validate_schema($schema))
1841 die "got strange schema" if !$schema->{type
} ||
1842 !$schema->{properties
} || $schema->{type
} ne 'object';
1847 my $handle_comment = sub { $_[0] =~ /^#/ };
1848 if (defined($comment_key)) {
1850 my $comment_re = qr/^\Q$comment_key\E:\s*(.*\S)\s*$/;
1851 $handle_comment = sub {
1852 if ($_[0] =~ /^\#(.*)\s*$/ || $_[0] =~ $comment_re) {
1853 $comment_data .= PVE
::Tools
::decode_text
($1) . "\n";
1860 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1863 next if $handle_comment->($line);
1865 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1868 if ($schema->{properties
}->{$key} &&
1869 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1871 $value = parse_boolean
($value) // $value;
1874 $schema->{properties
}->{$key}
1875 && $schema->{properties
}->{$key}->{type
} eq 'array'
1878 $cfg->{$key} //= [];
1879 push $cfg->{$key}->@*, $value;
1882 $cfg->{$key} = $value;
1884 warn "ignore config line: $line\n"
1888 if (defined($comment_data)) {
1889 $cfg->{$comment_key} = $comment_data;
1893 check_prop
($cfg, $schema, '', $errors);
1895 foreach my $k (keys %$errors) {
1896 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1903 # generate simple key/value file
1905 my ($schema, $filename, $cfg) = @_;
1907 # do fast check (avoid validate_schema($schema))
1908 die "got strange schema" if !$schema->{type
} ||
1909 !$schema->{properties
} || $schema->{type
} ne 'object';
1911 validate
($cfg, $schema, "validation error in '$filename'\n");
1915 foreach my $k (sort keys %$cfg) {
1916 $data .= "$k: $cfg->{$k}\n";
1922 # helpers used to generate our manual pages
1924 my $find_schema_default_key = sub {
1928 my $keyAliasProps = {};
1930 foreach my $key (keys %$format) {
1931 my $phash = $format->{$key};
1932 if ($phash->{default_key
}) {
1933 die "multiple default keys in schema ($default_key, $key)\n"
1934 if defined($default_key);
1935 die "default key '$key' is an alias - this is not allowed\n"
1936 if defined($phash->{alias
});
1937 die "default key '$key' with keyAlias attribute is not allowed\n"
1938 if $phash->{keyAlias
};
1939 $default_key = $key;
1941 my $key_alias = $phash->{keyAlias
};
1942 die "found keyAlias without 'alias definition for '$key'\n"
1943 if $key_alias && !$phash->{alias
};
1945 if ($phash->{alias
} && $key_alias) {
1946 die "inconsistent keyAlias '$key_alias' definition"
1947 if defined($keyAliasProps->{$key_alias}) &&
1948 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1949 $keyAliasProps->{$key_alias} = $phash->{alias
};
1953 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1956 sub generate_typetext
{
1957 my ($format, $list_enums) = @_;
1959 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1964 my $add_option_string = sub {
1965 my ($text, $optional) = @_;
1971 $text = "[$text]" if $optional;
1976 my $format_key_value = sub {
1977 my ($key, $phash) = @_;
1979 die "internal error" if defined($phash->{alias
});
1985 if (my $desc = $phash->{format_description
}) {
1986 $typetext .= "<$desc>";
1987 } elsif (my $text = $phash->{typetext
}) {
1989 } elsif (my $enum = $phash->{enum
}) {
1990 if ($list_enums || (scalar(@$enum) <= 3)) {
1991 $typetext .= '<' . join('|', @$enum) . '>';
1993 $typetext .= '<enum>';
1995 } elsif ($phash->{type
} eq 'boolean') {
1996 $typetext .= '<1|0>';
1997 } elsif ($phash->{type
} eq 'integer') {
1998 $typetext .= '<integer>';
1999 } elsif ($phash->{type
} eq 'number') {
2000 $typetext .= '<number>';
2002 die "internal error: neither format_description nor typetext found for option '$key'";
2005 if (defined($default_key) && ($default_key eq $key)) {
2006 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
2008 &$add_option_string("$keytext=$typetext", $phash->{optional
});
2014 my $cond_add_key = sub {
2017 return if $done->{$key}; # avoid duplicates
2021 my $phash = $format->{$key};
2023 return if !$phash; # should not happen
2025 return if $phash->{alias
};
2027 &$format_key_value($key, $phash);
2031 &$cond_add_key($default_key) if defined($default_key);
2033 # add required keys first
2034 foreach my $key (sort keys %$format) {
2035 my $phash = $format->{$key};
2036 &$cond_add_key($key) if $phash && !$phash->{optional
};
2040 foreach my $key (sort keys %$format) {
2041 &$cond_add_key($key);
2044 foreach my $keyAlias (sort keys %$keyAliasProps) {
2045 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
2051 sub print_property_string
{
2052 my ($data, $format, $skip, $path) = @_;
2055 if (ref($format) ne 'HASH') {
2056 my $schema = get_format
($format);
2057 die "not a valid format: $format\n" if !$schema;
2058 # named formats can have validators attached
2059 $validator = $format_validators->{$format};
2064 check_object
($path, $format, $data, undef, $errors);
2065 if (scalar(%$errors)) {
2066 raise
"format error", errors
=> $errors;
2069 $data = $validator->($data) if $validator;
2071 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
2076 my $add_option_string = sub {
2079 $res .= ',' if $add_sep;
2084 my $format_value = sub {
2085 my ($key, $value, $format) = @_;
2087 if (defined($format) && ($format eq 'disk-size')) {
2088 return format_size
($value);
2090 die "illegal value with commas for $key\n" if $value =~ /,/;
2095 my $done = { map { $_ => 1 } @$skip };
2097 my $cond_add_key = sub {
2098 my ($key, $isdefault) = @_;
2100 return if $done->{$key}; # avoid duplicates
2104 my $value = $data->{$key};
2106 return if !defined($value);
2108 my $phash = $format->{$key};
2110 # try to combine values if we have key aliases
2111 if (my $combine = $keyAliasProps->{$key}) {
2112 if (defined(my $combine_value = $data->{$combine})) {
2113 my $combine_format = $format->{$combine}->{format
};
2114 my $value_str = &$format_value($key, $value, $phash->{format
});
2115 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
2116 &$add_option_string("${value_str}=${combine_str}");
2117 $done->{$combine} = 1;
2122 if ($phash && $phash->{alias
}) {
2123 $phash = $format->{$phash->{alias
}};
2126 die "invalid key '$key'\n" if !$phash;
2127 die "internal error" if defined($phash->{alias
});
2129 my $value_str = &$format_value($key, $value, $phash->{format
});
2131 &$add_option_string($value_str);
2133 &$add_option_string("$key=${value_str}");
2137 # add default key first
2138 &$cond_add_key($default_key, 1) if defined($default_key);
2140 # add required keys first
2141 foreach my $key (sort keys %$data) {
2142 my $phash = $format->{$key};
2143 &$cond_add_key($key) if $phash && !$phash->{optional
};
2147 foreach my $key (sort keys %$data) {
2148 &$cond_add_key($key);
2154 sub schema_get_type_text
{
2155 my ($phash, $style) = @_;
2157 my $type = $phash->{type
} || 'string';
2159 if ($phash->{typetext
}) {
2160 return $phash->{typetext
};
2161 } elsif ($phash->{format_description
}) {
2162 return "<$phash->{format_description}>";
2163 } elsif ($phash->{enum
}) {
2164 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
2165 } elsif ($phash->{pattern
}) {
2166 return $phash->{pattern
};
2167 } elsif ($type eq 'integer' || $type eq 'number') {
2168 # NOTE: always access values as number (avoid converion to string)
2169 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
2170 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
2171 ($phash->{maximum
} + 0) . ")";
2172 } elsif (defined($phash->{minimum
})) {
2173 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
2174 } elsif (defined($phash->{maximum
})) {
2175 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
2177 } elsif ($type eq 'string') {
2178 if (my $format = $phash->{format
}) {
2179 $format = get_format
($format) if ref($format) ne 'HASH';
2180 if (ref($format) eq 'HASH') {
2182 $list_enums = 1 if $style && $style eq 'config-sub';
2183 return generate_typetext
($format, $list_enums);