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";
253 my ($idmap, $idformat) = @_;
255 return undef if !$idmap;
259 foreach my $entry (PVE
::Tools
::split_list
($idmap)) {
261 $map->{identity
} = 1;
262 } elsif ($entry =~ m/^([^:]+):([^:]+)$/) {
263 my ($source, $target) = ($1, $2);
265 check_format
($idformat, $source, '');
266 check_format
($idformat, $target, '');
268 die "entry '$entry' contains invalid ID - $@\n" if $@;
270 die "duplicate mapping for source '$source'\n"
271 if exists $map->{entries
}->{$source};
273 $map->{entries
}->{$source} = $target;
276 check_format
($idformat, $entry);
278 die "entry '$entry' contains invalid ID - $@\n" if $@;
280 die "default target ID can only be provided once\n"
281 if exists $map->{default};
283 $map->{default} = $entry;
287 die "identity mapping cannot be combined with other mappings\n"
288 if $map->{identity
} && ($map->{default} || exists $map->{entries
});
293 my $verify_idpair = sub {
294 my ($input, $noerr, $format) = @_;
296 eval { parse_idmap
($input, $format) };
298 return undef if $noerr;
305 # note: this only checks a single list entry
306 # when using a storage-pair-list map, you need to pass the full parameter to
308 register_format
('storage-pair', \
&verify_storagepair
);
309 sub verify_storagepair
{
310 my ($storagepair, $noerr) = @_;
311 return $verify_idpair->($storagepair, $noerr, 'pve-storage-id');
314 # note: this only checks a single list entry
315 # when using a bridge-pair-list map, you need to pass the full parameter to
317 register_format
('bridge-pair', \
&verify_bridgepair
);
318 sub verify_bridgepair
{
319 my ($bridgepair, $noerr) = @_;
320 return $verify_idpair->($bridgepair, $noerr, 'pve-bridge-id');
323 register_format
('mac-addr', \
&pve_verify_mac_addr
);
324 sub pve_verify_mac_addr
{
325 my ($mac_addr, $noerr) = @_;
327 # don't allow I/G bit to be set, most of the time it breaks things, see:
328 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
329 if ($mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i) {
330 return undef if $noerr;
331 die "value does not look like a valid unicast MAC address\n";
336 register_standard_option
('mac-addr', {
338 description
=> 'Unicast MAC address.',
339 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.',
340 format_description
=> "XX:XX:XX:XX:XX:XX",
342 format
=> 'mac-addr',
345 register_format
('ipv4', \
&pve_verify_ipv4
);
346 sub pve_verify_ipv4
{
347 my ($ipv4, $noerr) = @_;
349 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
350 return undef if $noerr;
351 die "value does not look like a valid IPv4 address\n";
356 register_format
('ipv6', \
&pve_verify_ipv6
);
357 sub pve_verify_ipv6
{
358 my ($ipv6, $noerr) = @_;
360 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
361 return undef if $noerr;
362 die "value does not look like a valid IPv6 address\n";
367 register_format
('ip', \
&pve_verify_ip
);
369 my ($ip, $noerr) = @_;
371 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
372 return undef if $noerr;
373 die "value does not look like a valid IP address\n";
378 PVE
::JSONSchema
::register_format
('ldap-simple-attr', \
&verify_ldap_simple_attr
);
379 sub verify_ldap_simple_attr
{
380 my ($attr, $noerr) = @_;
382 if ($attr =~ m/^[a-zA-Z0-9]+$/) {
386 die "value '$attr' does not look like a simple ldap attribute name\n" if !$noerr;
391 my $ipv4_mask_hash = {
409 '255.255.128.0' => 17,
410 '255.255.192.0' => 18,
411 '255.255.224.0' => 19,
412 '255.255.240.0' => 20,
413 '255.255.248.0' => 21,
414 '255.255.252.0' => 22,
415 '255.255.254.0' => 23,
416 '255.255.255.0' => 24,
417 '255.255.255.128' => 25,
418 '255.255.255.192' => 26,
419 '255.255.255.224' => 27,
420 '255.255.255.240' => 28,
421 '255.255.255.248' => 29,
422 '255.255.255.252' => 30,
423 '255.255.255.254' => 31,
424 '255.255.255.255' => 32,
427 sub get_netmask_bits
{
429 return $ipv4_mask_hash->{$mask};
432 register_format
('ipv4mask', \
&pve_verify_ipv4mask
);
433 sub pve_verify_ipv4mask
{
434 my ($mask, $noerr) = @_;
436 if (!defined($ipv4_mask_hash->{$mask})) {
437 return undef if $noerr;
438 die "value does not look like a valid IP netmask\n";
443 register_format
('CIDRv6', \
&pve_verify_cidrv6
);
444 sub pve_verify_cidrv6
{
445 my ($cidr, $noerr) = @_;
447 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
451 return undef if $noerr;
452 die "value does not look like a valid IPv6 CIDR network\n";
455 register_format
('CIDRv4', \
&pve_verify_cidrv4
);
456 sub pve_verify_cidrv4
{
457 my ($cidr, $noerr) = @_;
459 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
463 return undef if $noerr;
464 die "value does not look like a valid IPv4 CIDR network\n";
467 register_format
('CIDR', \
&pve_verify_cidr
);
468 sub pve_verify_cidr
{
469 my ($cidr, $noerr) = @_;
471 if (!(pve_verify_cidrv4
($cidr, 1) ||
472 pve_verify_cidrv6
($cidr, 1)))
474 return undef if $noerr;
475 die "value does not look like a valid CIDR network\n";
481 register_format
('pve-ipv4-config', \
&pve_verify_ipv4_config
);
482 sub pve_verify_ipv4_config
{
483 my ($config, $noerr) = @_;
485 return $config if $config =~ /^(?:dhcp|manual)$/ ||
486 pve_verify_cidrv4
($config, 1);
487 return undef if $noerr;
488 die "value does not look like a valid ipv4 network configuration\n";
491 register_format
('pve-ipv6-config', \
&pve_verify_ipv6_config
);
492 sub pve_verify_ipv6_config
{
493 my ($config, $noerr) = @_;
495 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
496 pve_verify_cidrv6
($config, 1);
497 return undef if $noerr;
498 die "value does not look like a valid ipv6 network configuration\n";
501 register_format
('email', \
&pve_verify_email
);
502 sub pve_verify_email
{
503 my ($email, $noerr) = @_;
505 if ($email !~ /^$PVE::Tools::EMAIL_RE$/) {
506 return undef if $noerr;
507 die "value does not look like a valid email address\n";
512 register_format
('email-or-username', \
&pve_verify_email_or_username
);
513 sub pve_verify_email_or_username
{
514 my ($email, $noerr) = @_;
516 if ($email !~ /^$PVE::Tools::EMAIL_RE$/ &&
517 $email !~ /^$PVE::Tools::EMAIL_USER_RE$/) {
518 return undef if $noerr;
519 die "value does not look like a valid email address or user name\n";
524 register_format
('dns-name', \
&pve_verify_dns_name
);
525 sub pve_verify_dns_name
{
526 my ($name, $noerr) = @_;
528 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
530 if ($name !~ /^(${namere}\.)*${namere}$/) {
531 return undef if $noerr;
532 die "value does not look like a valid DNS name\n";
537 register_format
('timezone', \
&pve_verify_timezone
);
538 sub pve_verify_timezone
{
539 my ($timezone, $noerr) = @_;
541 return $timezone if $timezone eq 'UTC';
543 open(my $fh, "<", "/usr/share/zoneinfo/zone.tab");
544 while (my $line = <$fh>) {
545 next if $line =~ /^\s*#/;
547 my $zone = (split /\t/, $line)[2];
548 return $timezone if $timezone eq $zone; # found
552 return undef if $noerr;
553 die "invalid time zone '$timezone'\n";
556 # network interface name
557 register_format
('pve-iface', \
&pve_verify_iface
);
558 sub pve_verify_iface
{
559 my ($id, $noerr) = @_;
561 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
562 return undef if $noerr;
563 die "invalid network interface name '$id'\n";
568 # general addresses by name or IP
569 register_format
('address', \
&pve_verify_address
);
570 sub pve_verify_address
{
571 my ($addr, $noerr) = @_;
573 if (!(pve_verify_ip
($addr, 1) ||
574 pve_verify_dns_name
($addr, 1)))
576 return undef if $noerr;
577 die "value does not look like a valid address: $addr\n";
582 register_format
('disk-size', \
&pve_verify_disk_size
);
583 sub pve_verify_disk_size
{
584 my ($size, $noerr) = @_;
585 if (!defined(parse_size
($size))) {
586 return undef if $noerr;
587 die "value does not look like a valid disk size: $size\n";
592 register_standard_option
('spice-proxy', {
593 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).",
594 type
=> 'string', format
=> 'address',
597 register_standard_option
('remote-viewer-config', {
598 description
=> "Returned values can be directly passed to the 'remote-viewer' application.",
599 additionalProperties
=> 1,
601 type
=> { type
=> 'string' },
602 password
=> { type
=> 'string' },
603 proxy
=> { type
=> 'string' },
604 host
=> { type
=> 'string' },
605 'tls-port' => { type
=> 'integer' },
609 register_format
('pve-startup-order', \
&pve_verify_startup_order
);
610 sub pve_verify_startup_order
{
611 my ($value, $noerr) = @_;
613 return $value if pve_parse_startup_order
($value);
615 return undef if $noerr;
617 die "unable to parse startup options\n";
622 type
=> 'number', minimum
=> '0',
623 format_description
=> 'LIMIT',
626 my $bwlimit_format = {
629 description
=> 'default bandwidth limit in KiB/s',
633 description
=> 'bandwidth limit in KiB/s for restoring guests from backups',
637 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)',
641 description
=> 'bandwidth limit in KiB/s for cloning disks',
645 description
=> 'bandwidth limit in KiB/s for moving disks',
648 register_format
('bwlimit', $bwlimit_format);
649 register_standard_option
('bwlimit', {
650 description
=> "Set bandwidth/io limits various operations.",
653 format
=> $bwlimit_format,
656 # used for pve-tag-list in e.g., guest configs
657 register_format
('pve-tag', \
&pve_verify_tag
);
659 my ($value, $noerr) = @_;
661 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i;
663 return undef if $noerr;
665 die "invalid characters in tag\n";
668 sub pve_parse_startup_order
{
671 return undef if !$value;
675 foreach my $p (split(/,/, $value)) {
676 next if $p =~ m/^\s*$/;
678 if ($p =~ m/^(order=)?(\d+)$/) {
680 } elsif ($p =~ m/^up=(\d+)$/) {
682 } elsif ($p =~ m/^down=(\d+)$/) {
692 PVE
::JSONSchema
::register_standard_option
('pve-startup-order', {
693 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.",
695 type
=> 'string', format
=> 'pve-startup-order',
696 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ',
699 register_format
('pve-tfa-secret', \
&pve_verify_tfa_secret
);
700 sub pve_verify_tfa_secret
{
701 my ($key, $noerr) = @_;
703 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
704 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
705 # format to support arbitrary lengths properly:
706 if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
707 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
708 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
713 return undef if $noerr;
715 die "unable to decode TFA secret\n";
719 PVE
::JSONSchema
::register_format
('pve-task-status-type', \
&verify_task_status_type
);
720 sub verify_task_status_type
{
721 my ($value, $noerr) = @_;
723 return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
725 return undef if $noerr;
727 die "invalid status '$value'\n";
731 my ($format, $value, $path) = @_;
733 if (ref($format) eq 'HASH') {
734 # hash ref cannot have validator/list/opt handling attached
735 return parse_property_string
($format, $value, $path);
738 if (ref($format) eq 'CODE') {
739 # we are the (sole, old-style) validator
740 return $format->($value);
743 return if $format eq 'regex';
746 $format =~ m/^(.*?)(?:-a?(list|opt))?$/;
747 my ($format_name, $format_type) = ($1, $2 // 'none');
748 my $registered = get_format
($format_name);
749 die "undefined format '$format'\n" if !$registered;
751 die "'-$format_type' format must have code ref, not hash\n"
752 if $format_type ne 'none' && ref($registered) ne 'CODE';
754 if ($format_type eq 'list') {
756 # Note: we allow empty lists
757 foreach my $v (split_list
($value)) {
758 push @{$parsed}, $registered->($v);
760 } elsif ($format_type eq 'opt') {
761 $parsed = $registered->($value) if $value;
763 if (ref($registered) eq 'HASH') {
764 # Note: this is the only case where a validator function could be
765 # attached, hence it's safe to handle that in parse_property_string.
766 # We do however have to call it with $format_name instead of
767 # $registered, so it knows about the name (and thus any validators).
768 $parsed = parse_property_string
($format, $value, $path);
770 $parsed = $registered->($value);
780 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
781 my ($size, $unit) = ($1, $3);
784 $size = $size * 1024;
785 } elsif ($unit eq 'M') {
786 $size = $size * 1024 * 1024;
787 } elsif ($unit eq 'G') {
788 $size = $size * 1024 * 1024 * 1024;
789 } elsif ($unit eq 'T') {
790 $size = $size * 1024 * 1024 * 1024 * 1024;
801 my $kb = int($size/1024);
802 return $size if $kb*1024 != $size;
804 my $mb = int($kb/1024);
805 return "${kb}K" if $mb*1024 != $kb;
807 my $gb = int($mb/1024);
808 return "${mb}M" if $gb*1024 != $mb;
810 my $tb = int($gb/1024);
811 return "${gb}G" if $tb*1024 != $gb;
818 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
819 return 0 if $bool =~ m/^(0|off|no|false)$/i;
823 sub parse_property_string
{
824 my ($format, $data, $path, $additional_properties) = @_;
826 # In property strings we default to not allowing additional properties
827 $additional_properties = 0 if !defined($additional_properties);
829 # Support named formats here, too:
832 if (my $reg = get_format
($format)) {
833 die "parse_property_string only accepts hash based named formats\n"
834 if ref($reg) ne 'HASH';
836 # named formats can have validators attached
837 $validator = $format_validators->{$format};
841 die "unknown format: $format\n";
843 } elsif (ref($format) ne 'HASH') {
844 die "unexpected format value of type ".ref($format)."\n";
850 foreach my $part (split(/,/, $data)) {
851 next if $part =~ /^\s*$/;
853 if ($part =~ /^([^=]+)=(.+)$/) {
854 my ($k, $v) = ($1, $2);
855 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
856 my $schema = $format->{$k};
857 if (my $alias = $schema->{alias
}) {
858 if (my $key_alias = $schema->{keyAlias
}) {
859 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
860 $res->{$key_alias} = $k;
863 $schema = $format->{$k};
866 die "invalid key in comma-separated list property: $k\n" if !$schema;
867 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
868 $v = parse_boolean
($v) // $v;
871 } elsif ($part !~ /=/) {
872 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
873 foreach my $key (keys %$format) {
874 if ($format->{$key}->{default_key
}) {
876 if (!$res->{$default_key}) {
877 $res->{$default_key} = $part;
880 die "duplicate key in comma-separated list property: $default_key\n";
883 die "value without key, but schema does not define a default key\n" if !$default_key;
885 die "missing key in comma-separated list property\n";
890 check_object
($path, $format, $res, $additional_properties, $errors);
891 if (scalar(%$errors)) {
892 raise
"format error\n", errors
=> $errors;
895 return $validator->($res) if $validator;
900 my ($errors, $path, $msg) = @_;
902 $path = '_root' if !$path;
904 if ($errors->{$path}) {
905 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
907 $errors->{$path} = $msg;
914 # see 'man perlretut'
915 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
921 return $value =~ m/^[+-]?\d+$/;
925 my ($path, $type, $value, $errors) = @_;
929 if (!defined($value)) {
930 return 1 if $type eq 'null';
934 if (my $tt = ref($type)) {
935 if ($tt eq 'ARRAY') {
936 foreach my $t (@$type) {
938 check_type
($path, $t, $value, $tmperr);
939 return 1 if !scalar(%$tmperr);
941 my $ttext = join ('|', @$type);
942 add_error
($errors, $path, "type check ('$ttext') failed");
944 } elsif ($tt eq 'HASH') {
946 check_prop
($value, $type, $path, $tmperr);
947 return 1 if !scalar(%$tmperr);
948 add_error
($errors, $path, "type check failed");
951 die "internal error - got reference type '$tt'";
956 return 1 if $type eq 'any';
958 if ($type eq 'null') {
959 if (defined($value)) {
960 add_error
($errors, $path, "type check ('$type') failed - value is not null");
966 my $vt = ref($value);
968 if ($type eq 'array') {
969 if (!$vt || $vt ne 'ARRAY') {
970 add_error
($errors, $path, "type check ('$type') failed");
974 } elsif ($type eq 'object') {
975 if (!$vt || $vt ne 'HASH') {
976 add_error
($errors, $path, "type check ('$type') failed");
980 } elsif ($type eq 'coderef') {
981 if (!$vt || $vt ne 'CODE') {
982 add_error
($errors, $path, "type check ('$type') failed");
986 } elsif ($type eq 'string' && $vt eq 'Regexp') {
987 # qr// regexes can be used as strings and make sense for format=regex
991 add_error
($errors, $path, "type check ('$type') failed - got $vt");
994 if ($type eq 'string') {
995 return 1; # nothing to check ?
996 } elsif ($type eq 'boolean') {
997 #if ($value =~ m/^(1|true|yes|on)$/i) {
1000 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
1001 } elsif ($value eq '0') {
1002 return 1; # return success (not value)
1004 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1007 } elsif ($type eq 'integer') {
1008 if (!is_integer
($value)) {
1009 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1013 } elsif ($type eq 'number') {
1014 if (!is_number
($value)) {
1015 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1020 return 1; # no need to verify unknown types
1030 my ($path, $schema, $value, $additional_properties, $errors) = @_;
1032 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
1034 my $st = ref($schema);
1035 if (!$st || $st ne 'HASH') {
1036 add_error
($errors, $path, "Invalid schema definition.");
1040 my $vt = ref($value);
1041 if (!$vt || $vt ne 'HASH') {
1042 add_error
($errors, $path, "an object is required");
1046 foreach my $k (keys %$schema) {
1047 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
1050 foreach my $k (keys %$value) {
1052 my $newpath = $path ?
"$path.$k" : $k;
1054 if (my $subschema = $schema->{$k}) {
1055 if (my $requires = $subschema->{requires
}) {
1056 if (ref($requires)) {
1057 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1058 check_prop
($value, $requires, $path, $errors);
1059 } elsif (!defined($value->{$requires})) {
1060 add_error
($errors, $path ?
"$path.$requires" : $requires,
1061 "missing property - '$newpath' requires this property");
1065 next; # value is already checked above
1068 if (defined ($additional_properties) && !$additional_properties) {
1069 add_error
($errors, $newpath, "property is not defined in schema " .
1070 "and the schema does not allow additional properties");
1073 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
1074 if ref($additional_properties);
1078 sub check_object_warn
{
1079 my ($path, $schema, $value, $additional_properties) = @_;
1081 check_object
($path, $schema, $value, $additional_properties, $errors);
1082 if (scalar(%$errors)) {
1083 foreach my $k (keys %$errors) {
1084 warn "parse error: $k: $errors->{$k}\n";
1092 my ($value, $schema, $path, $errors) = @_;
1094 die "internal error - no schema" if !$schema;
1095 die "internal error" if !$errors;
1097 #print "check_prop $path\n" if $value;
1099 my $st = ref($schema);
1100 if (!$st || $st ne 'HASH') {
1101 add_error
($errors, $path, "Invalid schema definition.");
1105 # if it extends another schema, it must pass that schema as well
1106 if($schema->{extends
}) {
1107 check_prop
($value, $schema->{extends
}, $path, $errors);
1110 if (!defined ($value)) {
1111 return if $schema->{type
} && $schema->{type
} eq 'null';
1112 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
1113 add_error
($errors, $path, "property is missing and it is not optional");
1118 return if !check_type
($path, $schema->{type
}, $value, $errors);
1120 if ($schema->{disallow
}) {
1122 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
1123 add_error
($errors, $path, "disallowed value was matched");
1128 if (my $vt = ref($value)) {
1130 if ($vt eq 'ARRAY') {
1131 if ($schema->{items
}) {
1132 my $it = ref($schema->{items
});
1133 if ($it && $it eq 'ARRAY') {
1134 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1135 die "not implemented";
1138 foreach my $el (@$value) {
1139 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
1145 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
1146 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
1147 $value, $schema->{additionalProperties
}, $errors);
1153 if (my $format = $schema->{format
}) {
1154 eval { check_format
($format, $value, $path); };
1156 add_error
($errors, $path, "invalid format - $@");
1161 if (my $pattern = $schema->{pattern
}) {
1162 if ($value !~ m/^$pattern$/) {
1163 add_error
($errors, $path, "value does not match the regex pattern");
1168 if (defined (my $max = $schema->{maxLength
})) {
1169 if (length($value) > $max) {
1170 add_error
($errors, $path, "value may only be $max characters long");
1175 if (defined (my $min = $schema->{minLength
})) {
1176 if (length($value) < $min) {
1177 add_error
($errors, $path, "value must be at least $min characters long");
1182 if (is_number
($value)) {
1183 if (defined (my $max = $schema->{maximum
})) {
1184 if ($value > $max) {
1185 add_error
($errors, $path, "value must have a maximum value of $max");
1190 if (defined (my $min = $schema->{minimum
})) {
1191 if ($value < $min) {
1192 add_error
($errors, $path, "value must have a minimum value of $min");
1198 if (my $ea = $schema->{enum
}) {
1201 foreach my $ev (@$ea) {
1202 if ($ev eq $value) {
1208 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
1209 join(", ", @$ea) . "'");
1216 my ($instance, $schema, $errmsg) = @_;
1219 $errmsg = "Parameter verification failed.\n" if !$errmsg;
1221 # todo: cycle detection is only needed for debugging, I guess
1222 # we can disable that in the final release
1223 # todo: is there a better/faster way to detect cycles?
1225 # 'download' responses can contain a filehandle, don't cycle-check that as
1226 # it produces a warning
1227 my $is_download = ref($instance) eq 'HASH' && exists($instance->{download
});
1228 find_cycle
($instance, sub { $cycles = 1 }) if !$is_download;
1230 add_error
($errors, undef, "data structure contains recursive cycles");
1232 check_prop
($instance, $schema, '', $errors);
1235 if (scalar(%$errors)) {
1236 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1242 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1243 my $default_schema_noref = {
1244 description
=> "This is the JSON Schema for JSON Schemas.",
1245 type
=> [ "object" ],
1246 additionalProperties
=> 0,
1249 type
=> ["string", "array"],
1250 description
=> "This is a type definition value. This can be a simple type, or a union type",
1255 enum
=> $schema_valid_types,
1257 enum
=> $schema_valid_types,
1261 description
=> "This indicates that the instance property in the instance object is not required.",
1267 description
=> "This is a definition for the properties of an object value",
1273 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1277 additionalProperties
=> {
1278 type
=> [ "boolean", "object"],
1279 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1286 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1291 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1295 description
=> "When the instance value is a string, this indicates minimum length of the string",
1302 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1308 description
=> "A text representation of the type (used to generate documentation).",
1313 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.",
1320 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1325 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).",
1327 verbose_description
=> {
1330 description
=> "This provides a more verbose description.",
1332 format_description
=> {
1335 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1340 description
=> "This provides the title of the property",
1345 description
=> "This is used to provide rendering hints to format cli command output.",
1348 type
=> [ "string", "object" ],
1350 description
=> "indicates a required property or a schema that must be validated if this property is present",
1353 type
=> [ "string", "object" ],
1355 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",
1360 description
=> "Whether this is the default key in a comma separated list property string.",
1365 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.",
1370 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1371 requires
=> 'alias',
1376 description
=> "This indicates the default for the instance property."
1380 description
=> "Bash completion function. This function should return a list of possible values.",
1386 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.",
1391 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1394 # this is from hyper schema
1397 description
=> "This defines the link relations of the instance objects",
1404 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",
1408 description
=> "This is the name of the link relation",
1414 description
=> "For submission links, this defines the method that should be used to access the target resource",
1423 description
=> "For CLI context, this defines the maximal width to print before truncating",
1429 my $default_schema = Storable
::dclone
($default_schema_noref);
1431 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1432 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1434 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1435 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1437 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1438 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1440 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1441 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1443 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1444 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1446 my $method_schema = {
1448 additionalProperties
=> 0,
1451 description
=> "This a description of the method",
1456 description
=> "This indicates the name of the function to call.",
1459 additionalProperties
=> 1,
1474 description
=> "The HTTP method name.",
1475 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1480 description
=> "Method needs special privileges - only pvedaemon can execute it",
1485 description
=> "Method is available for clients authenticated using an API token.",
1491 description
=> "Method downloads the file content (filename is the return value of the method).",
1496 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1499 proxyto_callback
=> {
1501 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1506 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1508 additionalProperties
=> 0,
1511 description
=> "Describe access permissions.",
1515 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1517 enum
=> ['all', 'world'],
1521 description
=> "Array of permission checks (prefix notation).",
1528 description
=> "Used internally",
1532 description
=> "Used internally",
1537 description
=> "path for URL matching (uri template)",
1539 fragmentDelimiter
=> {
1541 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.",
1546 description
=> "JSON Schema for parameters.",
1551 description
=> "JSON Schema for return value.",
1556 description
=> "method implementation (code reference)",
1561 description
=> "Delegate call to this class (perl class string).",
1564 additionalProperties
=> 0,
1570 fragmentDelimiter
=> { optional
=> 1 }
1578 sub validate_schema
{
1581 my $errmsg = "internal error - unable to verify schema\n";
1582 validate
($schema, $default_schema, $errmsg);
1585 sub validate_method_info
{
1588 my $errmsg = "internal error - unable to verify method info\n";
1589 validate
($info, $method_schema, $errmsg);
1591 validate_schema
($info->{parameters
}) if $info->{parameters
};
1592 validate_schema
($info->{returns
}) if $info->{returns
};
1595 # run a self test on load
1596 # make sure we can verify the default schema
1597 validate_schema
($default_schema_noref);
1598 validate_schema
($method_schema);
1600 # and now some utility methods (used by pve api)
1601 sub method_get_child_link
{
1604 return undef if !$info;
1606 my $schema = $info->{returns
};
1607 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1609 my $links = $schema->{links
};
1610 return undef if !$links;
1613 foreach my $lnk (@$links) {
1614 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1623 # a way to parse command line parameters, using a
1624 # schema to configure Getopt::Long
1626 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1628 if (!$schema || !$schema->{properties
}) {
1629 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1630 if scalar(@$args) != 0;
1635 if ($arg_param && !ref($arg_param)) {
1636 my $pd = $schema->{properties
}->{$arg_param};
1637 die "expected list format $pd->{format}"
1638 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1639 $list_param = $arg_param;
1642 my @interactive = ();
1644 foreach my $prop (keys %{$schema->{properties
}}) {
1645 my $pd = $schema->{properties
}->{$prop};
1646 next if $list_param && $prop eq $list_param;
1647 next if defined($fixed_param->{$prop});
1649 my $mapping = $param_mapping_hash->{$prop};
1650 if ($mapping && $mapping->{interactive
}) {
1651 # interactive parameters such as passwords: make the argument
1652 # optional and call the mapping function afterwards.
1653 push @getopt, "$prop:s";
1654 push @interactive, [$prop, $mapping->{func
}];
1655 } elsif ($pd->{type
} eq 'boolean') {
1656 push @getopt, "$prop:s";
1658 if ($pd->{format
} && $pd->{format
} =~ m/-a?list/) {
1659 push @getopt, "$prop=s@";
1661 push @getopt, "$prop=s";
1666 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1669 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1670 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1674 $opts->{$list_param} = $args;
1676 } elsif (ref($arg_param)) {
1677 for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1678 my $arg_name = $arg_param->[$i];
1679 if ($opts->{'extra-args'}) {
1680 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1682 if ($arg_name eq 'extra-args') {
1683 $opts->{'extra-args'} = $args;
1688 # check if all left-over arg_param are optional, else we
1689 # must die as the mapping is then ambigious
1690 for (; $i < scalar(@$arg_param); $i++) {
1691 my $prop = $arg_param->[$i];
1692 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
)
1693 if !$schema->{properties
}->{$prop}->{optional
};
1695 if ($arg_param->[-1] eq 'extra-args') {
1696 $opts->{'extra-args'} = [];
1700 $opts->{$arg_name} = shift @$args;
1702 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1704 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1705 if scalar(@$args) != 0;
1708 if (ref($arg_param)) {
1709 foreach my $arg_name (@$arg_param) {
1710 if ($arg_name eq 'extra-args') {
1711 $opts->{'extra-args'} = [];
1712 } elsif (!$schema->{properties
}->{$arg_name}->{optional
}) {
1713 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1719 foreach my $entry (@interactive) {
1720 my ($opt, $func) = @$entry;
1721 my $pd = $schema->{properties
}->{$opt};
1722 my $value = $opts->{$opt};
1723 if (defined($value) || !$pd->{optional
}) {
1724 $opts->{$opt} = $func->($value);
1728 # decode after Getopt as we are not sure how well it handles unicode
1729 foreach my $p (keys %$opts) {
1730 if (!ref($opts->{$p})) {
1731 $opts->{$p} = decode
('locale', $opts->{$p});
1732 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1734 foreach my $v (@{$opts->{$p}}) {
1735 push @$tmp, decode
('locale', $v);
1738 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1739 $opts->{$p} = decode
('locale', $$opts->{$p});
1741 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1745 foreach my $p (keys %$opts) {
1746 if (my $pd = $schema->{properties
}->{$p}) {
1747 if ($pd->{type
} eq 'boolean') {
1748 if ($opts->{$p} eq '') {
1750 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1751 $opts->{$p} = $bool;
1753 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1755 } elsif ($pd->{format
}) {
1757 if ($pd->{format
} =~ m/-list/) {
1758 # allow --vmid 100 --vmid 101 and --vmid 100,101
1759 # allow --dow mon --dow fri and --dow mon,fri
1760 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1761 } elsif ($pd->{format
} =~ m/-alist/) {
1762 # we encode array as \0 separated strings
1763 # Note: CGI.pm also use this encoding
1764 if (scalar(@{$opts->{$p}}) != 1) {
1765 $opts->{$p} = join("\0", @{$opts->{$p}});
1767 # st that split_list knows it is \0 terminated
1768 my $v = $opts->{$p}->[0];
1769 $opts->{$p} = "$v\0";
1776 foreach my $p (keys %$fixed_param) {
1777 $opts->{$p} = $fixed_param->{$p};
1783 # A way to parse configuration data by giving a json schema
1785 my ($schema, $filename, $raw) = @_;
1787 # do fast check (avoid validate_schema($schema))
1788 die "got strange schema" if !$schema->{type
} ||
1789 !$schema->{properties
} || $schema->{type
} ne 'object';
1793 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1796 next if $line =~ /^#/;
1798 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1801 if ($schema->{properties
}->{$key} &&
1802 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1804 $value = parse_boolean
($value) // $value;
1806 $cfg->{$key} = $value;
1808 warn "ignore config line: $line\n"
1813 check_prop
($cfg, $schema, '', $errors);
1815 foreach my $k (keys %$errors) {
1816 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1823 # generate simple key/value file
1825 my ($schema, $filename, $cfg) = @_;
1827 # do fast check (avoid validate_schema($schema))
1828 die "got strange schema" if !$schema->{type
} ||
1829 !$schema->{properties
} || $schema->{type
} ne 'object';
1831 validate
($cfg, $schema, "validation error in '$filename'\n");
1835 foreach my $k (sort keys %$cfg) {
1836 $data .= "$k: $cfg->{$k}\n";
1842 # helpers used to generate our manual pages
1844 my $find_schema_default_key = sub {
1848 my $keyAliasProps = {};
1850 foreach my $key (keys %$format) {
1851 my $phash = $format->{$key};
1852 if ($phash->{default_key
}) {
1853 die "multiple default keys in schema ($default_key, $key)\n"
1854 if defined($default_key);
1855 die "default key '$key' is an alias - this is not allowed\n"
1856 if defined($phash->{alias
});
1857 die "default key '$key' with keyAlias attribute is not allowed\n"
1858 if $phash->{keyAlias
};
1859 $default_key = $key;
1861 my $key_alias = $phash->{keyAlias
};
1862 die "found keyAlias without 'alias definition for '$key'\n"
1863 if $key_alias && !$phash->{alias
};
1865 if ($phash->{alias
} && $key_alias) {
1866 die "inconsistent keyAlias '$key_alias' definition"
1867 if defined($keyAliasProps->{$key_alias}) &&
1868 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1869 $keyAliasProps->{$key_alias} = $phash->{alias
};
1873 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1876 sub generate_typetext
{
1877 my ($format, $list_enums) = @_;
1879 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1884 my $add_option_string = sub {
1885 my ($text, $optional) = @_;
1891 $text = "[$text]" if $optional;
1896 my $format_key_value = sub {
1897 my ($key, $phash) = @_;
1899 die "internal error" if defined($phash->{alias
});
1905 if (my $desc = $phash->{format_description
}) {
1906 $typetext .= "<$desc>";
1907 } elsif (my $text = $phash->{typetext
}) {
1909 } elsif (my $enum = $phash->{enum
}) {
1910 if ($list_enums || (scalar(@$enum) <= 3)) {
1911 $typetext .= '<' . join('|', @$enum) . '>';
1913 $typetext .= '<enum>';
1915 } elsif ($phash->{type
} eq 'boolean') {
1916 $typetext .= '<1|0>';
1917 } elsif ($phash->{type
} eq 'integer') {
1918 $typetext .= '<integer>';
1919 } elsif ($phash->{type
} eq 'number') {
1920 $typetext .= '<number>';
1922 die "internal error: neither format_description nor typetext found for option '$key'";
1925 if (defined($default_key) && ($default_key eq $key)) {
1926 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
1928 &$add_option_string("$keytext=$typetext", $phash->{optional
});
1934 my $cond_add_key = sub {
1937 return if $done->{$key}; # avoid duplicates
1941 my $phash = $format->{$key};
1943 return if !$phash; # should not happen
1945 return if $phash->{alias
};
1947 &$format_key_value($key, $phash);
1951 &$cond_add_key($default_key) if defined($default_key);
1953 # add required keys first
1954 foreach my $key (sort keys %$format) {
1955 my $phash = $format->{$key};
1956 &$cond_add_key($key) if $phash && !$phash->{optional
};
1960 foreach my $key (sort keys %$format) {
1961 &$cond_add_key($key);
1964 foreach my $keyAlias (sort keys %$keyAliasProps) {
1965 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1971 sub print_property_string
{
1972 my ($data, $format, $skip, $path) = @_;
1975 if (ref($format) ne 'HASH') {
1976 my $schema = get_format
($format);
1977 die "not a valid format: $format\n" if !$schema;
1978 # named formats can have validators attached
1979 $validator = $format_validators->{$format};
1984 check_object
($path, $format, $data, undef, $errors);
1985 if (scalar(%$errors)) {
1986 raise
"format error", errors
=> $errors;
1989 $data = $validator->($data) if $validator;
1991 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1996 my $add_option_string = sub {
1999 $res .= ',' if $add_sep;
2004 my $format_value = sub {
2005 my ($key, $value, $format) = @_;
2007 if (defined($format) && ($format eq 'disk-size')) {
2008 return format_size
($value);
2010 die "illegal value with commas for $key\n" if $value =~ /,/;
2015 my $done = { map { $_ => 1 } @$skip };
2017 my $cond_add_key = sub {
2018 my ($key, $isdefault) = @_;
2020 return if $done->{$key}; # avoid duplicates
2024 my $value = $data->{$key};
2026 return if !defined($value);
2028 my $phash = $format->{$key};
2030 # try to combine values if we have key aliases
2031 if (my $combine = $keyAliasProps->{$key}) {
2032 if (defined(my $combine_value = $data->{$combine})) {
2033 my $combine_format = $format->{$combine}->{format
};
2034 my $value_str = &$format_value($key, $value, $phash->{format
});
2035 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
2036 &$add_option_string("${value_str}=${combine_str}");
2037 $done->{$combine} = 1;
2042 if ($phash && $phash->{alias
}) {
2043 $phash = $format->{$phash->{alias
}};
2046 die "invalid key '$key'\n" if !$phash;
2047 die "internal error" if defined($phash->{alias
});
2049 my $value_str = &$format_value($key, $value, $phash->{format
});
2051 &$add_option_string($value_str);
2053 &$add_option_string("$key=${value_str}");
2057 # add default key first
2058 &$cond_add_key($default_key, 1) if defined($default_key);
2060 # add required keys first
2061 foreach my $key (sort keys %$data) {
2062 my $phash = $format->{$key};
2063 &$cond_add_key($key) if $phash && !$phash->{optional
};
2067 foreach my $key (sort keys %$data) {
2068 &$cond_add_key($key);
2074 sub schema_get_type_text
{
2075 my ($phash, $style) = @_;
2077 my $type = $phash->{type
} || 'string';
2079 if ($phash->{typetext
}) {
2080 return $phash->{typetext
};
2081 } elsif ($phash->{format_description
}) {
2082 return "<$phash->{format_description}>";
2083 } elsif ($phash->{enum
}) {
2084 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
2085 } elsif ($phash->{pattern
}) {
2086 return $phash->{pattern
};
2087 } elsif ($type eq 'integer' || $type eq 'number') {
2088 # NOTE: always access values as number (avoid converion to string)
2089 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
2090 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
2091 ($phash->{maximum
} + 0) . ")";
2092 } elsif (defined($phash->{minimum
})) {
2093 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
2094 } elsif (defined($phash->{maximum
})) {
2095 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
2097 } elsif ($type eq 'string') {
2098 if (my $format = $phash->{format
}) {
2099 $format = get_format
($format) if ref($format) ne 'HASH';
2100 if (ref($format) eq 'HASH') {
2102 $list_enums = 1 if $style && $style eq 'config-sub';
2103 return generate_typetext
($format, $list_enums);