1 package PVE
::JSONSchema
;
5 use Storable
; # for dclone
9 use Devel
::Cycle
-quiet
; # todo: remove?
10 use PVE
::Tools
qw(split_list $IPV6RE $IPV4RE);
11 use PVE
::Exception
qw(raise);
12 use HTTP
::Status
qw(:constants);
13 use Net
::IP
qw(:PROC);
21 register_standard_option
24 our $CONFIGID_RE = qr/[a-z][a-z0-9_-]+/i;
26 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
27 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
28 # see: http://json-schema.org/
30 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
32 my $standard_options = {};
33 sub register_standard_option
{
34 my ($name, $schema) = @_;
36 die "standard option '$name' already registered\n"
37 if $standard_options->{$name};
39 $standard_options->{$name} = $schema;
42 sub get_standard_option
{
43 my ($name, $base) = @_;
45 my $std = $standard_options->{$name};
46 die "no such standard option '$name'\n" if !$std;
48 my $res = $base || {};
50 foreach my $opt (keys %$std) {
51 next if defined($res->{$opt});
52 $res->{$opt} = $std->{$opt};
58 register_standard_option
('pve-vmid', {
59 description
=> "The (unique) ID of the VM.",
60 type
=> 'integer', format
=> 'pve-vmid',
64 register_standard_option
('pve-node', {
65 description
=> "The cluster node name.",
66 type
=> 'string', format
=> 'pve-node',
69 register_standard_option
('pve-node-list', {
70 description
=> "List of cluster node names.",
71 type
=> 'string', format
=> 'pve-node-list',
74 register_standard_option
('pve-iface', {
75 description
=> "Network interface name.",
76 type
=> 'string', format
=> 'pve-iface',
77 minLength
=> 2, maxLength
=> 20,
80 register_standard_option
('pve-storage-id', {
81 description
=> "The storage identifier.",
82 type
=> 'string', format
=> 'pve-storage-id',
85 register_standard_option
('pve-bridge-id', {
86 description
=> "Bridge to attach guest network devices to.",
87 type
=> 'string', format
=> 'pve-bridge-id',
88 format_description
=> 'bridge',
91 register_standard_option
('pve-config-digest', {
92 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
95 maxLength
=> 40, # sha1 hex digest length is 40
98 register_standard_option
('skiplock', {
99 description
=> "Ignore locks - only root is allowed to use this option.",
104 register_standard_option
('extra-args', {
105 description
=> "Extra arguments as array",
107 items
=> { type
=> 'string' },
111 register_standard_option
('fingerprint-sha256', {
112 description
=> "Certificate SHA 256 fingerprint.",
114 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
117 register_standard_option
('pve-output-format', {
119 description
=> 'Output format.',
120 enum
=> [ 'text', 'json', 'json-pretty', 'yaml' ],
125 register_standard_option
('pve-snapshot-name', {
126 description
=> "The name of the snapshot.",
127 type
=> 'string', format
=> 'pve-configid',
131 my $format_list = {};
132 my $format_validators = {};
134 sub register_format
{
135 my ($name, $format, $validator) = @_;
137 die "JSON schema format '$name' already registered\n"
138 if $format_list->{$name};
141 die "A \$validator function can only be specified for hash-based formats\n"
142 if ref($format) ne 'HASH';
143 $format_validators->{$name} = $validator;
146 $format_list->{$name} = $format;
151 return $format_list->{$name};
154 my $renderer_hash = {};
156 sub register_renderer
{
157 my ($name, $code) = @_;
159 die "renderer '$name' already registered\n"
160 if $renderer_hash->{$name};
162 $renderer_hash->{$name} = $code;
167 return $renderer_hash->{$name};
170 # register some common type for pve
172 register_format
('string', sub {}); # allow format => 'string-list'
174 register_format
('urlencoded', \
&pve_verify_urlencoded
);
175 sub pve_verify_urlencoded
{
176 my ($text, $noerr) = @_;
177 if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
178 return undef if $noerr;
179 die "invalid urlencoded string: $text\n";
184 register_format
('pve-configid', \
&pve_verify_configid
);
185 sub pve_verify_configid
{
186 my ($id, $noerr) = @_;
188 if ($id !~ m/^$CONFIGID_RE$/) {
189 return undef if $noerr;
190 die "invalid configuration ID '$id'\n";
195 PVE
::JSONSchema
::register_format
('pve-storage-id', \
&parse_storage_id
);
196 sub parse_storage_id
{
197 my ($storeid, $noerr) = @_;
199 return parse_id
($storeid, 'storage', $noerr);
202 PVE
::JSONSchema
::register_format
('pve-bridge-id', \
&parse_bridge_id
);
203 sub parse_bridge_id
{
204 my ($id, $noerr) = @_;
206 if ($id !~ m/^[-_.\w\d]+$/) {
207 return undef if $noerr;
208 die "invalid bridge ID '$id'\n";
213 PVE
::JSONSchema
::register_format
('acme-plugin-id', \
&parse_acme_plugin_id
);
214 sub parse_acme_plugin_id
{
215 my ($pluginid, $noerr) = @_;
217 return parse_id
($pluginid, 'ACME plugin', $noerr);
221 my ($id, $type, $noerr) = @_;
223 if ($id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
224 return undef if $noerr;
225 die "$type ID '$id' contains illegal characters\n";
230 register_format
('pve-vmid', \
&pve_verify_vmid
);
231 sub pve_verify_vmid
{
232 my ($vmid, $noerr) = @_;
234 if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
235 return undef if $noerr;
236 die "value does not look like a valid VM ID\n";
241 register_format
('pve-node', \
&pve_verify_node_name
);
242 sub pve_verify_node_name
{
243 my ($node, $noerr) = @_;
245 if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
246 return undef if $noerr;
247 die "value does not look like a valid node name\n";
252 # maps source to target ID using an ID map
254 my ($map, $source) = @_;
256 return $source if !defined($map);
258 return $map->{entries
}->{$source}
259 if $map->{entries
} && defined($map->{entries
}->{$source});
261 return $map->{default} if $map->{default};
263 # identity (fallback)
268 my ($idmap, $idformat) = @_;
270 return undef if !$idmap;
274 foreach my $entry (PVE
::Tools
::split_list
($idmap)) {
276 $map->{identity
} = 1;
277 } elsif ($entry =~ m/^([^:]+):([^:]+)$/) {
278 my ($source, $target) = ($1, $2);
280 check_format
($idformat, $source, '');
281 check_format
($idformat, $target, '');
283 die "entry '$entry' contains invalid ID - $@\n" if $@;
285 die "duplicate mapping for source '$source'\n"
286 if exists $map->{entries
}->{$source};
288 $map->{entries
}->{$source} = $target;
291 check_format
($idformat, $entry);
293 die "entry '$entry' contains invalid ID - $@\n" if $@;
295 die "default target ID can only be provided once\n"
296 if exists $map->{default};
298 $map->{default} = $entry;
302 die "identity mapping cannot be combined with other mappings\n"
303 if $map->{identity
} && ($map->{default} || exists $map->{entries
});
308 my $verify_idpair = sub {
309 my ($input, $noerr, $format) = @_;
311 eval { parse_idmap
($input, $format) };
313 return undef if $noerr;
320 # note: this only checks a single list entry
321 # when using a storage-pair-list map, you need to pass the full parameter to
323 register_format
('storage-pair', \
&verify_storagepair
);
324 sub verify_storagepair
{
325 my ($storagepair, $noerr) = @_;
326 return $verify_idpair->($storagepair, $noerr, 'pve-storage-id');
329 # note: this only checks a single list entry
330 # when using a bridge-pair-list map, you need to pass the full parameter to
332 register_format
('bridge-pair', \
&verify_bridgepair
);
333 sub verify_bridgepair
{
334 my ($bridgepair, $noerr) = @_;
335 return $verify_idpair->($bridgepair, $noerr, 'pve-bridge-id');
338 register_format
('mac-addr', \
&pve_verify_mac_addr
);
339 sub pve_verify_mac_addr
{
340 my ($mac_addr, $noerr) = @_;
342 # don't allow I/G bit to be set, most of the time it breaks things, see:
343 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
344 if ($mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i) {
345 return undef if $noerr;
346 die "value does not look like a valid unicast MAC address\n";
351 register_standard_option
('mac-addr', {
353 description
=> 'Unicast MAC address.',
354 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.',
355 format_description
=> "XX:XX:XX:XX:XX:XX",
357 format
=> 'mac-addr',
360 register_format
('ipv4', \
&pve_verify_ipv4
);
361 sub pve_verify_ipv4
{
362 my ($ipv4, $noerr) = @_;
364 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
365 return undef if $noerr;
366 die "value does not look like a valid IPv4 address\n";
371 register_format
('ipv6', \
&pve_verify_ipv6
);
372 sub pve_verify_ipv6
{
373 my ($ipv6, $noerr) = @_;
375 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
376 return undef if $noerr;
377 die "value does not look like a valid IPv6 address\n";
382 register_format
('ip', \
&pve_verify_ip
);
384 my ($ip, $noerr) = @_;
386 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
387 return undef if $noerr;
388 die "value does not look like a valid IP address\n";
393 PVE
::JSONSchema
::register_format
('ldap-simple-attr', \
&verify_ldap_simple_attr
);
394 sub verify_ldap_simple_attr
{
395 my ($attr, $noerr) = @_;
397 if ($attr =~ m/^[a-zA-Z0-9]+$/) {
401 die "value '$attr' does not look like a simple ldap attribute name\n" if !$noerr;
406 my $ipv4_mask_hash = {
424 '255.255.128.0' => 17,
425 '255.255.192.0' => 18,
426 '255.255.224.0' => 19,
427 '255.255.240.0' => 20,
428 '255.255.248.0' => 21,
429 '255.255.252.0' => 22,
430 '255.255.254.0' => 23,
431 '255.255.255.0' => 24,
432 '255.255.255.128' => 25,
433 '255.255.255.192' => 26,
434 '255.255.255.224' => 27,
435 '255.255.255.240' => 28,
436 '255.255.255.248' => 29,
437 '255.255.255.252' => 30,
438 '255.255.255.254' => 31,
439 '255.255.255.255' => 32,
442 sub get_netmask_bits
{
444 return $ipv4_mask_hash->{$mask};
447 register_format
('ipv4mask', \
&pve_verify_ipv4mask
);
448 sub pve_verify_ipv4mask
{
449 my ($mask, $noerr) = @_;
451 if (!defined($ipv4_mask_hash->{$mask})) {
452 return undef if $noerr;
453 die "value does not look like a valid IP netmask\n";
458 register_format
('CIDRv6', \
&pve_verify_cidrv6
);
459 sub pve_verify_cidrv6
{
460 my ($cidr, $noerr) = @_;
462 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
466 return undef if $noerr;
467 die "value does not look like a valid IPv6 CIDR network\n";
470 register_format
('CIDRv4', \
&pve_verify_cidrv4
);
471 sub pve_verify_cidrv4
{
472 my ($cidr, $noerr) = @_;
474 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
478 return undef if $noerr;
479 die "value does not look like a valid IPv4 CIDR network\n";
482 register_format
('CIDR', \
&pve_verify_cidr
);
483 sub pve_verify_cidr
{
484 my ($cidr, $noerr) = @_;
486 if (!(pve_verify_cidrv4
($cidr, 1) ||
487 pve_verify_cidrv6
($cidr, 1)))
489 return undef if $noerr;
490 die "value does not look like a valid CIDR network\n";
496 register_format
('pve-ipv4-config', \
&pve_verify_ipv4_config
);
497 sub pve_verify_ipv4_config
{
498 my ($config, $noerr) = @_;
500 return $config if $config =~ /^(?:dhcp|manual)$/ ||
501 pve_verify_cidrv4
($config, 1);
502 return undef if $noerr;
503 die "value does not look like a valid ipv4 network configuration\n";
506 register_format
('pve-ipv6-config', \
&pve_verify_ipv6_config
);
507 sub pve_verify_ipv6_config
{
508 my ($config, $noerr) = @_;
510 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
511 pve_verify_cidrv6
($config, 1);
512 return undef if $noerr;
513 die "value does not look like a valid ipv6 network configuration\n";
516 register_format
('email', \
&pve_verify_email
);
517 sub pve_verify_email
{
518 my ($email, $noerr) = @_;
520 if ($email !~ /^$PVE::Tools::EMAIL_RE$/) {
521 return undef if $noerr;
522 die "value does not look like a valid email address\n";
527 register_format
('email-or-username', \
&pve_verify_email_or_username
);
528 sub pve_verify_email_or_username
{
529 my ($email, $noerr) = @_;
531 if ($email !~ /^$PVE::Tools::EMAIL_RE$/ &&
532 $email !~ /^$PVE::Tools::EMAIL_USER_RE$/) {
533 return undef if $noerr;
534 die "value does not look like a valid email address or user name\n";
539 register_format
('dns-name', \
&pve_verify_dns_name
);
540 sub pve_verify_dns_name
{
541 my ($name, $noerr) = @_;
543 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
545 if ($name !~ /^(${namere}\.)*${namere}$/) {
546 return undef if $noerr;
547 die "value does not look like a valid DNS name\n";
552 register_format
('timezone', \
&pve_verify_timezone
);
553 sub pve_verify_timezone
{
554 my ($timezone, $noerr) = @_;
556 return $timezone if $timezone eq 'UTC';
558 open(my $fh, "<", "/usr/share/zoneinfo/zone.tab");
559 while (my $line = <$fh>) {
560 next if $line =~ /^\s*#/;
562 my $zone = (split /\t/, $line)[2];
563 return $timezone if $timezone eq $zone; # found
567 return undef if $noerr;
568 die "invalid time zone '$timezone'\n";
571 # network interface name
572 register_format
('pve-iface', \
&pve_verify_iface
);
573 sub pve_verify_iface
{
574 my ($id, $noerr) = @_;
576 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
577 return undef if $noerr;
578 die "invalid network interface name '$id'\n";
583 # general addresses by name or IP
584 register_format
('address', \
&pve_verify_address
);
585 sub pve_verify_address
{
586 my ($addr, $noerr) = @_;
588 if (!(pve_verify_ip
($addr, 1) ||
589 pve_verify_dns_name
($addr, 1)))
591 return undef if $noerr;
592 die "value does not look like a valid address: $addr\n";
597 register_format
('disk-size', \
&pve_verify_disk_size
);
598 sub pve_verify_disk_size
{
599 my ($size, $noerr) = @_;
600 if (!defined(parse_size
($size))) {
601 return undef if $noerr;
602 die "value does not look like a valid disk size: $size\n";
607 register_standard_option
('spice-proxy', {
608 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).",
609 type
=> 'string', format
=> 'address',
612 register_standard_option
('remote-viewer-config', {
613 description
=> "Returned values can be directly passed to the 'remote-viewer' application.",
614 additionalProperties
=> 1,
616 type
=> { type
=> 'string' },
617 password
=> { type
=> 'string' },
618 proxy
=> { type
=> 'string' },
619 host
=> { type
=> 'string' },
620 'tls-port' => { type
=> 'integer' },
624 register_format
('pve-startup-order', \
&pve_verify_startup_order
);
625 sub pve_verify_startup_order
{
626 my ($value, $noerr) = @_;
628 return $value if pve_parse_startup_order
($value);
630 return undef if $noerr;
632 die "unable to parse startup options\n";
637 type
=> 'number', minimum
=> '0',
638 format_description
=> 'LIMIT',
641 my $bwlimit_format = {
644 description
=> 'default bandwidth limit in KiB/s',
648 description
=> 'bandwidth limit in KiB/s for restoring guests from backups',
652 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)',
656 description
=> 'bandwidth limit in KiB/s for cloning disks',
660 description
=> 'bandwidth limit in KiB/s for moving disks',
663 register_format
('bwlimit', $bwlimit_format);
664 register_standard_option
('bwlimit', {
665 description
=> "Set bandwidth/io limits various operations.",
668 format
=> $bwlimit_format,
671 my $remote_format = {
674 format_description
=> 'Remote Proxmox hostname or IP',
682 format_description
=> 'A full Proxmox API token including the secret value.',
684 fingerprint
=> get_standard_option
(
685 'fingerprint-sha256',
688 format_description
=> 'Remote host\'s certificate fingerprint, if not trusted by system store.',
692 register_format
('proxmox-remote', $remote_format);
693 register_standard_option
('proxmox-remote', {
694 description
=> "Specification of a remote endpoint.",
695 type
=> 'string', format
=> 'proxmox-remote',
698 # used for pve-tag-list in e.g., guest configs
699 register_format
('pve-tag', \
&pve_verify_tag
);
701 my ($value, $noerr) = @_;
703 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i;
705 return undef if $noerr;
707 die "invalid characters in tag\n";
710 sub pve_parse_startup_order
{
713 return undef if !$value;
717 foreach my $p (split(/,/, $value)) {
718 next if $p =~ m/^\s*$/;
720 if ($p =~ m/^(order=)?(\d+)$/) {
722 } elsif ($p =~ m/^up=(\d+)$/) {
724 } elsif ($p =~ m/^down=(\d+)$/) {
734 PVE
::JSONSchema
::register_standard_option
('pve-startup-order', {
735 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.",
737 type
=> 'string', format
=> 'pve-startup-order',
738 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ',
741 register_format
('pve-tfa-secret', \
&pve_verify_tfa_secret
);
742 sub pve_verify_tfa_secret
{
743 my ($key, $noerr) = @_;
745 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
746 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
747 # format to support arbitrary lengths properly:
748 if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
749 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
750 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
755 return undef if $noerr;
757 die "unable to decode TFA secret\n";
761 PVE
::JSONSchema
::register_format
('pve-task-status-type', \
&verify_task_status_type
);
762 sub verify_task_status_type
{
763 my ($value, $noerr) = @_;
765 return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
767 return undef if $noerr;
769 die "invalid status '$value'\n";
773 my ($format, $value, $path) = @_;
775 if (ref($format) eq 'HASH') {
776 # hash ref cannot have validator/list/opt handling attached
777 return parse_property_string
($format, $value, $path);
780 if (ref($format) eq 'CODE') {
781 # we are the (sole, old-style) validator
782 return $format->($value);
785 return if $format eq 'regex';
788 $format =~ m/^(.*?)(?:-a?(list|opt))?$/;
789 my ($format_name, $format_type) = ($1, $2 // 'none');
790 my $registered = get_format
($format_name);
791 die "undefined format '$format'\n" if !$registered;
793 die "'-$format_type' format must have code ref, not hash\n"
794 if $format_type ne 'none' && ref($registered) ne 'CODE';
796 if ($format_type eq 'list') {
798 # Note: we allow empty lists
799 foreach my $v (split_list
($value)) {
800 push @{$parsed}, $registered->($v);
802 } elsif ($format_type eq 'opt') {
803 $parsed = $registered->($value) if $value;
805 if (ref($registered) eq 'HASH') {
806 # Note: this is the only case where a validator function could be
807 # attached, hence it's safe to handle that in parse_property_string.
808 # We do however have to call it with $format_name instead of
809 # $registered, so it knows about the name (and thus any validators).
810 $parsed = parse_property_string
($format, $value, $path);
812 $parsed = $registered->($value);
822 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
823 my ($size, $unit) = ($1, $3);
826 $size = $size * 1024;
827 } elsif ($unit eq 'M') {
828 $size = $size * 1024 * 1024;
829 } elsif ($unit eq 'G') {
830 $size = $size * 1024 * 1024 * 1024;
831 } elsif ($unit eq 'T') {
832 $size = $size * 1024 * 1024 * 1024 * 1024;
843 my $kb = int($size/1024);
844 return $size if $kb*1024 != $size;
846 my $mb = int($kb/1024);
847 return "${kb}K" if $mb*1024 != $kb;
849 my $gb = int($mb/1024);
850 return "${mb}M" if $gb*1024 != $mb;
852 my $tb = int($gb/1024);
853 return "${gb}G" if $tb*1024 != $gb;
860 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
861 return 0 if $bool =~ m/^(0|off|no|false)$/i;
865 sub parse_property_string
{
866 my ($format, $data, $path, $additional_properties) = @_;
868 # In property strings we default to not allowing additional properties
869 $additional_properties = 0 if !defined($additional_properties);
871 # Support named formats here, too:
874 if (my $reg = get_format
($format)) {
875 die "parse_property_string only accepts hash based named formats\n"
876 if ref($reg) ne 'HASH';
878 # named formats can have validators attached
879 $validator = $format_validators->{$format};
883 die "unknown format: $format\n";
885 } elsif (ref($format) ne 'HASH') {
886 die "unexpected format value of type ".ref($format)."\n";
892 foreach my $part (split(/,/, $data)) {
893 next if $part =~ /^\s*$/;
895 if ($part =~ /^([^=]+)=(.+)$/) {
896 my ($k, $v) = ($1, $2);
897 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
898 my $schema = $format->{$k};
899 if (my $alias = $schema->{alias
}) {
900 if (my $key_alias = $schema->{keyAlias
}) {
901 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
902 $res->{$key_alias} = $k;
905 $schema = $format->{$k};
908 die "invalid key in comma-separated list property: $k\n" if !$schema;
909 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
910 $v = parse_boolean
($v) // $v;
913 } elsif ($part !~ /=/) {
914 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
915 foreach my $key (keys %$format) {
916 if ($format->{$key}->{default_key
}) {
918 if (!$res->{$default_key}) {
919 $res->{$default_key} = $part;
922 die "duplicate key in comma-separated list property: $default_key\n";
925 die "value without key, but schema does not define a default key\n" if !$default_key;
927 die "missing key in comma-separated list property\n";
932 check_object
($path, $format, $res, $additional_properties, $errors);
933 if (scalar(%$errors)) {
934 raise
"format error\n", errors
=> $errors;
937 return $validator->($res) if $validator;
942 my ($errors, $path, $msg) = @_;
944 $path = '_root' if !$path;
946 if ($errors->{$path}) {
947 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
949 $errors->{$path} = $msg;
956 # see 'man perlretut'
957 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
963 return $value =~ m/^[+-]?\d+$/;
967 my ($path, $type, $value, $errors) = @_;
971 if (!defined($value)) {
972 return 1 if $type eq 'null';
976 if (my $tt = ref($type)) {
977 if ($tt eq 'ARRAY') {
978 foreach my $t (@$type) {
980 check_type
($path, $t, $value, $tmperr);
981 return 1 if !scalar(%$tmperr);
983 my $ttext = join ('|', @$type);
984 add_error
($errors, $path, "type check ('$ttext') failed");
986 } elsif ($tt eq 'HASH') {
988 check_prop
($value, $type, $path, $tmperr);
989 return 1 if !scalar(%$tmperr);
990 add_error
($errors, $path, "type check failed");
993 die "internal error - got reference type '$tt'";
998 return 1 if $type eq 'any';
1000 if ($type eq 'null') {
1001 if (defined($value)) {
1002 add_error
($errors, $path, "type check ('$type') failed - value is not null");
1008 my $vt = ref($value);
1010 if ($type eq 'array') {
1011 if (!$vt || $vt ne 'ARRAY') {
1012 add_error
($errors, $path, "type check ('$type') failed");
1016 } elsif ($type eq 'object') {
1017 if (!$vt || $vt ne 'HASH') {
1018 add_error
($errors, $path, "type check ('$type') failed");
1022 } elsif ($type eq 'coderef') {
1023 if (!$vt || $vt ne 'CODE') {
1024 add_error
($errors, $path, "type check ('$type') failed");
1028 } elsif ($type eq 'string' && $vt eq 'Regexp') {
1029 # qr// regexes can be used as strings and make sense for format=regex
1033 add_error
($errors, $path, "type check ('$type') failed - got $vt");
1036 if ($type eq 'string') {
1037 return 1; # nothing to check ?
1038 } elsif ($type eq 'boolean') {
1039 #if ($value =~ m/^(1|true|yes|on)$/i) {
1040 if ($value eq '1') {
1042 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
1043 } elsif ($value eq '0') {
1044 return 1; # return success (not value)
1046 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1049 } elsif ($type eq 'integer') {
1050 if (!is_integer
($value)) {
1051 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1055 } elsif ($type eq 'number') {
1056 if (!is_number
($value)) {
1057 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1062 return 1; # no need to verify unknown types
1072 my ($path, $schema, $value, $additional_properties, $errors) = @_;
1074 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
1076 my $st = ref($schema);
1077 if (!$st || $st ne 'HASH') {
1078 add_error
($errors, $path, "Invalid schema definition.");
1082 my $vt = ref($value);
1083 if (!$vt || $vt ne 'HASH') {
1084 add_error
($errors, $path, "an object is required");
1088 foreach my $k (keys %$schema) {
1089 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
1092 foreach my $k (keys %$value) {
1094 my $newpath = $path ?
"$path.$k" : $k;
1096 if (my $subschema = $schema->{$k}) {
1097 if (my $requires = $subschema->{requires
}) {
1098 if (ref($requires)) {
1099 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1100 check_prop
($value, $requires, $path, $errors);
1101 } elsif (!defined($value->{$requires})) {
1102 add_error
($errors, $path ?
"$path.$requires" : $requires,
1103 "missing property - '$newpath' requires this property");
1107 next; # value is already checked above
1110 if (defined ($additional_properties) && !$additional_properties) {
1111 add_error
($errors, $newpath, "property is not defined in schema " .
1112 "and the schema does not allow additional properties");
1115 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
1116 if ref($additional_properties);
1120 sub check_object_warn
{
1121 my ($path, $schema, $value, $additional_properties) = @_;
1123 check_object
($path, $schema, $value, $additional_properties, $errors);
1124 if (scalar(%$errors)) {
1125 foreach my $k (keys %$errors) {
1126 warn "parse error: $k: $errors->{$k}\n";
1134 my ($value, $schema, $path, $errors) = @_;
1136 die "internal error - no schema" if !$schema;
1137 die "internal error" if !$errors;
1139 #print "check_prop $path\n" if $value;
1141 my $st = ref($schema);
1142 if (!$st || $st ne 'HASH') {
1143 add_error
($errors, $path, "Invalid schema definition.");
1147 # if it extends another schema, it must pass that schema as well
1148 if($schema->{extends
}) {
1149 check_prop
($value, $schema->{extends
}, $path, $errors);
1152 if (!defined ($value)) {
1153 return if $schema->{type
} && $schema->{type
} eq 'null';
1154 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
1155 add_error
($errors, $path, "property is missing and it is not optional");
1160 return if !check_type
($path, $schema->{type
}, $value, $errors);
1162 if ($schema->{disallow
}) {
1164 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
1165 add_error
($errors, $path, "disallowed value was matched");
1170 if (my $vt = ref($value)) {
1172 if ($vt eq 'ARRAY') {
1173 if ($schema->{items
}) {
1174 my $it = ref($schema->{items
});
1175 if ($it && $it eq 'ARRAY') {
1176 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1177 die "not implemented";
1180 foreach my $el (@$value) {
1181 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
1187 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
1188 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
1189 $value, $schema->{additionalProperties
}, $errors);
1195 if (my $format = $schema->{format
}) {
1196 eval { check_format
($format, $value, $path); };
1198 add_error
($errors, $path, "invalid format - $@");
1203 if (my $pattern = $schema->{pattern
}) {
1204 if ($value !~ m/^$pattern$/) {
1205 add_error
($errors, $path, "value does not match the regex pattern");
1210 if (defined (my $max = $schema->{maxLength
})) {
1211 if (length($value) > $max) {
1212 add_error
($errors, $path, "value may only be $max characters long");
1217 if (defined (my $min = $schema->{minLength
})) {
1218 if (length($value) < $min) {
1219 add_error
($errors, $path, "value must be at least $min characters long");
1224 if (is_number
($value)) {
1225 if (defined (my $max = $schema->{maximum
})) {
1226 if ($value > $max) {
1227 add_error
($errors, $path, "value must have a maximum value of $max");
1232 if (defined (my $min = $schema->{minimum
})) {
1233 if ($value < $min) {
1234 add_error
($errors, $path, "value must have a minimum value of $min");
1240 if (my $ea = $schema->{enum
}) {
1243 foreach my $ev (@$ea) {
1244 if ($ev eq $value) {
1250 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
1251 join(", ", @$ea) . "'");
1258 my ($instance, $schema, $errmsg) = @_;
1261 $errmsg = "Parameter verification failed.\n" if !$errmsg;
1263 # todo: cycle detection is only needed for debugging, I guess
1264 # we can disable that in the final release
1265 # todo: is there a better/faster way to detect cycles?
1267 # 'download' responses can contain a filehandle, don't cycle-check that as
1268 # it produces a warning
1269 my $is_download = ref($instance) eq 'HASH' && exists($instance->{download
});
1270 find_cycle
($instance, sub { $cycles = 1 }) if !$is_download;
1272 add_error
($errors, undef, "data structure contains recursive cycles");
1274 check_prop
($instance, $schema, '', $errors);
1277 if (scalar(%$errors)) {
1278 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1284 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1285 my $default_schema_noref = {
1286 description
=> "This is the JSON Schema for JSON Schemas.",
1287 type
=> [ "object" ],
1288 additionalProperties
=> 0,
1291 type
=> ["string", "array"],
1292 description
=> "This is a type definition value. This can be a simple type, or a union type",
1297 enum
=> $schema_valid_types,
1299 enum
=> $schema_valid_types,
1303 description
=> "This indicates that the instance property in the instance object is not required.",
1309 description
=> "This is a definition for the properties of an object value",
1315 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1319 additionalProperties
=> {
1320 type
=> [ "boolean", "object"],
1321 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1328 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1333 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1337 description
=> "When the instance value is a string, this indicates minimum length of the string",
1344 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1350 description
=> "A text representation of the type (used to generate documentation).",
1355 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.",
1362 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1367 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).",
1369 verbose_description
=> {
1372 description
=> "This provides a more verbose description.",
1374 format_description
=> {
1377 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1382 description
=> "This provides the title of the property",
1387 description
=> "This is used to provide rendering hints to format cli command output.",
1390 type
=> [ "string", "object" ],
1392 description
=> "indicates a required property or a schema that must be validated if this property is present",
1395 type
=> [ "string", "object" ],
1397 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",
1402 description
=> "Whether this is the default key in a comma separated list property string.",
1407 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.",
1412 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1413 requires
=> 'alias',
1418 description
=> "This indicates the default for the instance property."
1422 description
=> "Bash completion function. This function should return a list of possible values.",
1428 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.",
1433 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1436 # this is from hyper schema
1439 description
=> "This defines the link relations of the instance objects",
1446 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",
1450 description
=> "This is the name of the link relation",
1456 description
=> "For submission links, this defines the method that should be used to access the target resource",
1465 description
=> "For CLI context, this defines the maximal width to print before truncating",
1471 my $default_schema = Storable
::dclone
($default_schema_noref);
1473 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1474 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1476 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1477 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1479 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1480 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1482 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1483 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1485 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1486 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1488 my $method_schema = {
1490 additionalProperties
=> 0,
1493 description
=> "This a description of the method",
1498 description
=> "This indicates the name of the function to call.",
1501 additionalProperties
=> 1,
1516 description
=> "The HTTP method name.",
1517 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1522 description
=> "Method needs special privileges - only pvedaemon can execute it",
1527 description
=> "Method is available for clients authenticated using an API token.",
1533 description
=> "Method downloads the file content (filename is the return value of the method).",
1538 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1541 proxyto_callback
=> {
1543 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1548 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1550 additionalProperties
=> 0,
1553 description
=> "Describe access permissions.",
1557 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1559 enum
=> ['all', 'world'],
1563 description
=> "Array of permission checks (prefix notation).",
1570 description
=> "Used internally",
1574 description
=> "Used internally",
1579 description
=> "path for URL matching (uri template)",
1581 fragmentDelimiter
=> {
1583 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.",
1588 description
=> "JSON Schema for parameters.",
1593 description
=> "JSON Schema for return value.",
1598 description
=> "method implementation (code reference)",
1603 description
=> "Delegate call to this class (perl class string).",
1606 additionalProperties
=> 0,
1612 fragmentDelimiter
=> { optional
=> 1 }
1620 sub validate_schema
{
1623 my $errmsg = "internal error - unable to verify schema\n";
1624 validate
($schema, $default_schema, $errmsg);
1627 sub validate_method_info
{
1630 my $errmsg = "internal error - unable to verify method info\n";
1631 validate
($info, $method_schema, $errmsg);
1633 validate_schema
($info->{parameters
}) if $info->{parameters
};
1634 validate_schema
($info->{returns
}) if $info->{returns
};
1637 # run a self test on load
1638 # make sure we can verify the default schema
1639 validate_schema
($default_schema_noref);
1640 validate_schema
($method_schema);
1642 # and now some utility methods (used by pve api)
1643 sub method_get_child_link
{
1646 return undef if !$info;
1648 my $schema = $info->{returns
};
1649 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1651 my $links = $schema->{links
};
1652 return undef if !$links;
1655 foreach my $lnk (@$links) {
1656 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1665 # a way to parse command line parameters, using a
1666 # schema to configure Getopt::Long
1668 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1670 if (!$schema || !$schema->{properties
}) {
1671 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1672 if scalar(@$args) != 0;
1677 if ($arg_param && !ref($arg_param)) {
1678 my $pd = $schema->{properties
}->{$arg_param};
1679 die "expected list format $pd->{format}"
1680 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1681 $list_param = $arg_param;
1684 my @interactive = ();
1686 foreach my $prop (keys %{$schema->{properties
}}) {
1687 my $pd = $schema->{properties
}->{$prop};
1688 next if $list_param && $prop eq $list_param;
1689 next if defined($fixed_param->{$prop});
1691 my $mapping = $param_mapping_hash->{$prop};
1692 if ($mapping && $mapping->{interactive
}) {
1693 # interactive parameters such as passwords: make the argument
1694 # optional and call the mapping function afterwards.
1695 push @getopt, "$prop:s";
1696 push @interactive, [$prop, $mapping->{func
}];
1697 } elsif ($pd->{type
} eq 'boolean') {
1698 push @getopt, "$prop:s";
1700 if ($pd->{format
} && $pd->{format
} =~ m/-a?list/) {
1701 push @getopt, "$prop=s@";
1703 push @getopt, "$prop=s";
1708 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1711 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1712 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1716 $opts->{$list_param} = $args;
1718 } elsif (ref($arg_param)) {
1719 for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1720 my $arg_name = $arg_param->[$i];
1721 if ($opts->{'extra-args'}) {
1722 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1724 if ($arg_name eq 'extra-args') {
1725 $opts->{'extra-args'} = $args;
1730 # check if all left-over arg_param are optional, else we
1731 # must die as the mapping is then ambigious
1732 for (; $i < scalar(@$arg_param); $i++) {
1733 my $prop = $arg_param->[$i];
1734 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
)
1735 if !$schema->{properties
}->{$prop}->{optional
};
1737 if ($arg_param->[-1] eq 'extra-args') {
1738 $opts->{'extra-args'} = [];
1742 $opts->{$arg_name} = shift @$args;
1744 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1746 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1747 if scalar(@$args) != 0;
1750 if (ref($arg_param)) {
1751 foreach my $arg_name (@$arg_param) {
1752 if ($arg_name eq 'extra-args') {
1753 $opts->{'extra-args'} = [];
1754 } elsif (!$schema->{properties
}->{$arg_name}->{optional
}) {
1755 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1761 foreach my $entry (@interactive) {
1762 my ($opt, $func) = @$entry;
1763 my $pd = $schema->{properties
}->{$opt};
1764 my $value = $opts->{$opt};
1765 if (defined($value) || !$pd->{optional
}) {
1766 $opts->{$opt} = $func->($value);
1770 # decode after Getopt as we are not sure how well it handles unicode
1771 foreach my $p (keys %$opts) {
1772 if (!ref($opts->{$p})) {
1773 $opts->{$p} = decode
('locale', $opts->{$p});
1774 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1776 foreach my $v (@{$opts->{$p}}) {
1777 push @$tmp, decode
('locale', $v);
1780 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1781 $opts->{$p} = decode
('locale', $$opts->{$p});
1783 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1787 foreach my $p (keys %$opts) {
1788 if (my $pd = $schema->{properties
}->{$p}) {
1789 if ($pd->{type
} eq 'boolean') {
1790 if ($opts->{$p} eq '') {
1792 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1793 $opts->{$p} = $bool;
1795 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1797 } elsif ($pd->{format
}) {
1799 if ($pd->{format
} =~ m/-list/) {
1800 # allow --vmid 100 --vmid 101 and --vmid 100,101
1801 # allow --dow mon --dow fri and --dow mon,fri
1802 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1803 } elsif ($pd->{format
} =~ m/-alist/) {
1804 # we encode array as \0 separated strings
1805 # Note: CGI.pm also use this encoding
1806 if (scalar(@{$opts->{$p}}) != 1) {
1807 $opts->{$p} = join("\0", @{$opts->{$p}});
1809 # st that split_list knows it is \0 terminated
1810 my $v = $opts->{$p}->[0];
1811 $opts->{$p} = "$v\0";
1818 foreach my $p (keys %$fixed_param) {
1819 $opts->{$p} = $fixed_param->{$p};
1825 # A way to parse configuration data by giving a json schema
1827 my ($schema, $filename, $raw) = @_;
1829 # do fast check (avoid validate_schema($schema))
1830 die "got strange schema" if !$schema->{type
} ||
1831 !$schema->{properties
} || $schema->{type
} ne 'object';
1835 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1838 next if $line =~ /^#/;
1840 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1843 if ($schema->{properties
}->{$key} &&
1844 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1846 $value = parse_boolean
($value) // $value;
1848 $cfg->{$key} = $value;
1850 warn "ignore config line: $line\n"
1855 check_prop
($cfg, $schema, '', $errors);
1857 foreach my $k (keys %$errors) {
1858 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1865 # generate simple key/value file
1867 my ($schema, $filename, $cfg) = @_;
1869 # do fast check (avoid validate_schema($schema))
1870 die "got strange schema" if !$schema->{type
} ||
1871 !$schema->{properties
} || $schema->{type
} ne 'object';
1873 validate
($cfg, $schema, "validation error in '$filename'\n");
1877 foreach my $k (sort keys %$cfg) {
1878 $data .= "$k: $cfg->{$k}\n";
1884 # helpers used to generate our manual pages
1886 my $find_schema_default_key = sub {
1890 my $keyAliasProps = {};
1892 foreach my $key (keys %$format) {
1893 my $phash = $format->{$key};
1894 if ($phash->{default_key
}) {
1895 die "multiple default keys in schema ($default_key, $key)\n"
1896 if defined($default_key);
1897 die "default key '$key' is an alias - this is not allowed\n"
1898 if defined($phash->{alias
});
1899 die "default key '$key' with keyAlias attribute is not allowed\n"
1900 if $phash->{keyAlias
};
1901 $default_key = $key;
1903 my $key_alias = $phash->{keyAlias
};
1904 die "found keyAlias without 'alias definition for '$key'\n"
1905 if $key_alias && !$phash->{alias
};
1907 if ($phash->{alias
} && $key_alias) {
1908 die "inconsistent keyAlias '$key_alias' definition"
1909 if defined($keyAliasProps->{$key_alias}) &&
1910 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1911 $keyAliasProps->{$key_alias} = $phash->{alias
};
1915 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1918 sub generate_typetext
{
1919 my ($format, $list_enums) = @_;
1921 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1926 my $add_option_string = sub {
1927 my ($text, $optional) = @_;
1933 $text = "[$text]" if $optional;
1938 my $format_key_value = sub {
1939 my ($key, $phash) = @_;
1941 die "internal error" if defined($phash->{alias
});
1947 if (my $desc = $phash->{format_description
}) {
1948 $typetext .= "<$desc>";
1949 } elsif (my $text = $phash->{typetext
}) {
1951 } elsif (my $enum = $phash->{enum
}) {
1952 if ($list_enums || (scalar(@$enum) <= 3)) {
1953 $typetext .= '<' . join('|', @$enum) . '>';
1955 $typetext .= '<enum>';
1957 } elsif ($phash->{type
} eq 'boolean') {
1958 $typetext .= '<1|0>';
1959 } elsif ($phash->{type
} eq 'integer') {
1960 $typetext .= '<integer>';
1961 } elsif ($phash->{type
} eq 'number') {
1962 $typetext .= '<number>';
1964 die "internal error: neither format_description nor typetext found for option '$key'";
1967 if (defined($default_key) && ($default_key eq $key)) {
1968 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
1970 &$add_option_string("$keytext=$typetext", $phash->{optional
});
1976 my $cond_add_key = sub {
1979 return if $done->{$key}; # avoid duplicates
1983 my $phash = $format->{$key};
1985 return if !$phash; # should not happen
1987 return if $phash->{alias
};
1989 &$format_key_value($key, $phash);
1993 &$cond_add_key($default_key) if defined($default_key);
1995 # add required keys first
1996 foreach my $key (sort keys %$format) {
1997 my $phash = $format->{$key};
1998 &$cond_add_key($key) if $phash && !$phash->{optional
};
2002 foreach my $key (sort keys %$format) {
2003 &$cond_add_key($key);
2006 foreach my $keyAlias (sort keys %$keyAliasProps) {
2007 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
2013 sub print_property_string
{
2014 my ($data, $format, $skip, $path) = @_;
2017 if (ref($format) ne 'HASH') {
2018 my $schema = get_format
($format);
2019 die "not a valid format: $format\n" if !$schema;
2020 # named formats can have validators attached
2021 $validator = $format_validators->{$format};
2026 check_object
($path, $format, $data, undef, $errors);
2027 if (scalar(%$errors)) {
2028 raise
"format error", errors
=> $errors;
2031 $data = $validator->($data) if $validator;
2033 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
2038 my $add_option_string = sub {
2041 $res .= ',' if $add_sep;
2046 my $format_value = sub {
2047 my ($key, $value, $format) = @_;
2049 if (defined($format) && ($format eq 'disk-size')) {
2050 return format_size
($value);
2052 die "illegal value with commas for $key\n" if $value =~ /,/;
2057 my $done = { map { $_ => 1 } @$skip };
2059 my $cond_add_key = sub {
2060 my ($key, $isdefault) = @_;
2062 return if $done->{$key}; # avoid duplicates
2066 my $value = $data->{$key};
2068 return if !defined($value);
2070 my $phash = $format->{$key};
2072 # try to combine values if we have key aliases
2073 if (my $combine = $keyAliasProps->{$key}) {
2074 if (defined(my $combine_value = $data->{$combine})) {
2075 my $combine_format = $format->{$combine}->{format
};
2076 my $value_str = &$format_value($key, $value, $phash->{format
});
2077 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
2078 &$add_option_string("${value_str}=${combine_str}");
2079 $done->{$combine} = 1;
2084 if ($phash && $phash->{alias
}) {
2085 $phash = $format->{$phash->{alias
}};
2088 die "invalid key '$key'\n" if !$phash;
2089 die "internal error" if defined($phash->{alias
});
2091 my $value_str = &$format_value($key, $value, $phash->{format
});
2093 &$add_option_string($value_str);
2095 &$add_option_string("$key=${value_str}");
2099 # add default key first
2100 &$cond_add_key($default_key, 1) if defined($default_key);
2102 # add required keys first
2103 foreach my $key (sort keys %$data) {
2104 my $phash = $format->{$key};
2105 &$cond_add_key($key) if $phash && !$phash->{optional
};
2109 foreach my $key (sort keys %$data) {
2110 &$cond_add_key($key);
2116 sub schema_get_type_text
{
2117 my ($phash, $style) = @_;
2119 my $type = $phash->{type
} || 'string';
2121 if ($phash->{typetext
}) {
2122 return $phash->{typetext
};
2123 } elsif ($phash->{format_description
}) {
2124 return "<$phash->{format_description}>";
2125 } elsif ($phash->{enum
}) {
2126 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
2127 } elsif ($phash->{pattern
}) {
2128 return $phash->{pattern
};
2129 } elsif ($type eq 'integer' || $type eq 'number') {
2130 # NOTE: always access values as number (avoid converion to string)
2131 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
2132 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
2133 ($phash->{maximum
} + 0) . ")";
2134 } elsif (defined($phash->{minimum
})) {
2135 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
2136 } elsif (defined($phash->{maximum
})) {
2137 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
2139 } elsif ($type eq 'string') {
2140 if (my $format = $phash->{format
}) {
2141 $format = get_format
($format) if ref($format) ne 'HASH';
2142 if (ref($format) eq 'HASH') {
2144 $list_enums = 1 if $style && $style eq 'config-sub';
2145 return generate_typetext
($format, $list_enums);