1 package PVE
::JSONSchema
;
5 use Storable
; # for dclone
9 use Devel
::Cycle
-quiet
; # todo: remove?
10 use PVE
::Tools
qw(split_list $IPV6RE $IPV4RE);
11 use PVE
::Exception
qw(raise);
12 use HTTP
::Status
qw(:constants);
13 use Net
::IP
qw(:PROC);
19 register_standard_option
25 our $CONFIGID_RE = qr/[a-z][a-z0-9_-]+/i;
27 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
28 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
29 # see: http://json-schema.org/
31 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
33 my $standard_options = {};
34 sub register_standard_option
{
35 my ($name, $schema) = @_;
37 die "standard option '$name' already registered\n"
38 if $standard_options->{$name};
40 $standard_options->{$name} = $schema;
43 sub get_standard_option
{
44 my ($name, $base) = @_;
46 my $std = $standard_options->{$name};
47 die "no such standard option '$name'\n" if !$std;
49 my $res = $base || {};
51 foreach my $opt (keys %$std) {
52 next if defined($res->{$opt});
53 $res->{$opt} = $std->{$opt};
59 register_standard_option
('pve-vmid', {
60 description
=> "The (unique) ID of the VM.",
61 type
=> 'integer', format
=> 'pve-vmid',
65 register_standard_option
('pve-node', {
66 description
=> "The cluster node name.",
67 type
=> 'string', format
=> 'pve-node',
70 register_standard_option
('pve-node-list', {
71 description
=> "List of cluster node names.",
72 type
=> 'string', format
=> 'pve-node-list',
75 register_standard_option
('pve-iface', {
76 description
=> "Network interface name.",
77 type
=> 'string', format
=> 'pve-iface',
78 minLength
=> 2, maxLength
=> 20,
81 register_standard_option
('pve-storage-id', {
82 description
=> "The storage identifier.",
83 type
=> 'string', format
=> 'pve-storage-id',
86 register_standard_option
('pve-bridge-id', {
87 description
=> "Bridge to attach guest network devices to.",
88 type
=> 'string', format
=> 'pve-bridge-id',
89 format_description
=> 'bridge',
92 register_standard_option
('pve-config-digest', {
93 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
96 maxLength
=> 40, # sha1 hex digest length is 40
99 register_standard_option
('skiplock', {
100 description
=> "Ignore locks - only root is allowed to use this option.",
105 register_standard_option
('extra-args', {
106 description
=> "Extra arguments as array",
108 items
=> { type
=> 'string' },
112 register_standard_option
('fingerprint-sha256', {
113 description
=> "Certificate SHA 256 fingerprint.",
115 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
118 register_standard_option
('pve-output-format', {
120 description
=> 'Output format.',
121 enum
=> [ 'text', 'json', 'json-pretty', 'yaml' ],
126 register_standard_option
('pve-snapshot-name', {
127 description
=> "The name of the snapshot.",
128 type
=> 'string', format
=> 'pve-configid',
132 my $format_list = {};
133 my $format_validators = {};
135 sub register_format
{
136 my ($name, $format, $validator) = @_;
138 die "JSON schema format '$name' already registered\n"
139 if $format_list->{$name};
142 die "A \$validator function can only be specified for hash-based formats\n"
143 if ref($format) ne 'HASH';
144 $format_validators->{$name} = $validator;
147 $format_list->{$name} = $format;
152 return $format_list->{$name};
155 my $renderer_hash = {};
157 sub register_renderer
{
158 my ($name, $code) = @_;
160 die "renderer '$name' already registered\n"
161 if $renderer_hash->{$name};
163 $renderer_hash->{$name} = $code;
168 return $renderer_hash->{$name};
171 # register some common type for pve
173 register_format
('string', sub {}); # allow format => 'string-list'
175 register_format
('urlencoded', \
&pve_verify_urlencoded
);
176 sub pve_verify_urlencoded
{
177 my ($text, $noerr) = @_;
178 if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
179 return undef if $noerr;
180 die "invalid urlencoded string: $text\n";
185 register_format
('pve-configid', \
&pve_verify_configid
);
186 sub pve_verify_configid
{
187 my ($id, $noerr) = @_;
189 if ($id !~ m/^$CONFIGID_RE$/) {
190 return undef if $noerr;
191 die "invalid configuration ID '$id'\n";
196 PVE
::JSONSchema
::register_format
('pve-storage-id', \
&parse_storage_id
);
197 sub parse_storage_id
{
198 my ($storeid, $noerr) = @_;
200 return parse_id
($storeid, 'storage', $noerr);
203 PVE
::JSONSchema
::register_format
('pve-bridge-id', \
&parse_bridge_id
);
204 sub parse_bridge_id
{
205 my ($id, $noerr) = @_;
207 if ($id !~ m/^[-_.\w\d]+$/) {
208 return undef if $noerr;
209 die "invalid bridge ID '$id'\n";
214 PVE
::JSONSchema
::register_format
('acme-plugin-id', \
&parse_acme_plugin_id
);
215 sub parse_acme_plugin_id
{
216 my ($pluginid, $noerr) = @_;
218 return parse_id
($pluginid, 'ACME plugin', $noerr);
222 my ($id, $type, $noerr) = @_;
224 if ($id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
225 return undef if $noerr;
226 die "$type ID '$id' contains illegal characters\n";
231 register_format
('pve-vmid', \
&pve_verify_vmid
);
232 sub pve_verify_vmid
{
233 my ($vmid, $noerr) = @_;
235 if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
236 return undef if $noerr;
237 die "value does not look like a valid VM ID\n";
242 register_format
('pve-node', \
&pve_verify_node_name
);
243 sub pve_verify_node_name
{
244 my ($node, $noerr) = @_;
246 if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
247 return undef if $noerr;
248 die "value does not look like a valid node name\n";
253 # maps source to target ID using an ID map
255 my ($map, $source) = @_;
257 return $source if !defined($map);
259 return $map->{entries
}->{$source}
260 if $map->{entries
} && defined($map->{entries
}->{$source});
262 return $map->{default} if $map->{default};
264 # identity (fallback)
269 my ($idmap, $idformat) = @_;
271 return undef if !$idmap;
275 foreach my $entry (PVE
::Tools
::split_list
($idmap)) {
277 $map->{identity
} = 1;
278 } elsif ($entry =~ m/^([^:]+):([^:]+)$/) {
279 my ($source, $target) = ($1, $2);
281 check_format
($idformat, $source, '');
282 check_format
($idformat, $target, '');
284 die "entry '$entry' contains invalid ID - $@\n" if $@;
286 die "duplicate mapping for source '$source'\n"
287 if exists $map->{entries
}->{$source};
289 $map->{entries
}->{$source} = $target;
292 check_format
($idformat, $entry);
294 die "entry '$entry' contains invalid ID - $@\n" if $@;
296 die "default target ID can only be provided once\n"
297 if exists $map->{default};
299 $map->{default} = $entry;
303 die "identity mapping cannot be combined with other mappings\n"
304 if $map->{identity
} && ($map->{default} || exists $map->{entries
});
309 my $verify_idpair = sub {
310 my ($input, $noerr, $format) = @_;
312 eval { parse_idmap
($input, $format) };
314 return undef if $noerr;
321 # note: this only checks a single list entry
322 # when using a storage-pair-list map, you need to pass the full parameter to
324 register_format
('storage-pair', \
&verify_storagepair
);
325 sub verify_storagepair
{
326 my ($storagepair, $noerr) = @_;
327 return $verify_idpair->($storagepair, $noerr, 'pve-storage-id');
330 # note: this only checks a single list entry
331 # when using a bridge-pair-list map, you need to pass the full parameter to
333 register_format
('bridge-pair', \
&verify_bridgepair
);
334 sub verify_bridgepair
{
335 my ($bridgepair, $noerr) = @_;
336 return $verify_idpair->($bridgepair, $noerr, 'pve-bridge-id');
339 register_format
('mac-addr', \
&pve_verify_mac_addr
);
340 sub pve_verify_mac_addr
{
341 my ($mac_addr, $noerr) = @_;
343 # don't allow I/G bit to be set, most of the time it breaks things, see:
344 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
345 if ($mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i) {
346 return undef if $noerr;
347 die "value does not look like a valid unicast MAC address\n";
352 register_standard_option
('mac-addr', {
354 description
=> 'Unicast MAC address.',
355 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.',
356 format_description
=> "XX:XX:XX:XX:XX:XX",
358 format
=> 'mac-addr',
361 register_format
('ipv4', \
&pve_verify_ipv4
);
362 sub pve_verify_ipv4
{
363 my ($ipv4, $noerr) = @_;
365 if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
366 return undef if $noerr;
367 die "value does not look like a valid IPv4 address\n";
372 register_format
('ipv6', \
&pve_verify_ipv6
);
373 sub pve_verify_ipv6
{
374 my ($ipv6, $noerr) = @_;
376 if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
377 return undef if $noerr;
378 die "value does not look like a valid IPv6 address\n";
383 register_format
('ip', \
&pve_verify_ip
);
385 my ($ip, $noerr) = @_;
387 if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
388 return undef if $noerr;
389 die "value does not look like a valid IP address\n";
394 PVE
::JSONSchema
::register_format
('ldap-simple-attr', \
&verify_ldap_simple_attr
);
395 sub verify_ldap_simple_attr
{
396 my ($attr, $noerr) = @_;
398 if ($attr =~ m/^[a-zA-Z0-9]+$/) {
402 die "value '$attr' does not look like a simple ldap attribute name\n" if !$noerr;
407 my $ipv4_mask_hash = {
425 '255.255.128.0' => 17,
426 '255.255.192.0' => 18,
427 '255.255.224.0' => 19,
428 '255.255.240.0' => 20,
429 '255.255.248.0' => 21,
430 '255.255.252.0' => 22,
431 '255.255.254.0' => 23,
432 '255.255.255.0' => 24,
433 '255.255.255.128' => 25,
434 '255.255.255.192' => 26,
435 '255.255.255.224' => 27,
436 '255.255.255.240' => 28,
437 '255.255.255.248' => 29,
438 '255.255.255.252' => 30,
439 '255.255.255.254' => 31,
440 '255.255.255.255' => 32,
443 sub get_netmask_bits
{
445 return $ipv4_mask_hash->{$mask};
448 register_format
('ipv4mask', \
&pve_verify_ipv4mask
);
449 sub pve_verify_ipv4mask
{
450 my ($mask, $noerr) = @_;
452 if (!defined($ipv4_mask_hash->{$mask})) {
453 return undef if $noerr;
454 die "value does not look like a valid IP netmask\n";
459 register_format
('CIDRv6', \
&pve_verify_cidrv6
);
460 sub pve_verify_cidrv6
{
461 my ($cidr, $noerr) = @_;
463 if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
467 return undef if $noerr;
468 die "value does not look like a valid IPv6 CIDR network\n";
471 register_format
('CIDRv4', \
&pve_verify_cidrv4
);
472 sub pve_verify_cidrv4
{
473 my ($cidr, $noerr) = @_;
475 if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
479 return undef if $noerr;
480 die "value does not look like a valid IPv4 CIDR network\n";
483 register_format
('CIDR', \
&pve_verify_cidr
);
484 sub pve_verify_cidr
{
485 my ($cidr, $noerr) = @_;
487 if (!(pve_verify_cidrv4
($cidr, 1) ||
488 pve_verify_cidrv6
($cidr, 1)))
490 return undef if $noerr;
491 die "value does not look like a valid CIDR network\n";
497 register_format
('pve-ipv4-config', \
&pve_verify_ipv4_config
);
498 sub pve_verify_ipv4_config
{
499 my ($config, $noerr) = @_;
501 return $config if $config =~ /^(?:dhcp|manual)$/ ||
502 pve_verify_cidrv4
($config, 1);
503 return undef if $noerr;
504 die "value does not look like a valid ipv4 network configuration\n";
507 register_format
('pve-ipv6-config', \
&pve_verify_ipv6_config
);
508 sub pve_verify_ipv6_config
{
509 my ($config, $noerr) = @_;
511 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
512 pve_verify_cidrv6
($config, 1);
513 return undef if $noerr;
514 die "value does not look like a valid ipv6 network configuration\n";
517 register_format
('email', \
&pve_verify_email
);
518 sub pve_verify_email
{
519 my ($email, $noerr) = @_;
521 if ($email !~ /^$PVE::Tools::EMAIL_RE$/) {
522 return undef if $noerr;
523 die "value does not look like a valid email address\n";
528 register_format
('email-or-username', \
&pve_verify_email_or_username
);
529 sub pve_verify_email_or_username
{
530 my ($email, $noerr) = @_;
532 if ($email !~ /^$PVE::Tools::EMAIL_RE$/ &&
533 $email !~ /^$PVE::Tools::EMAIL_USER_RE$/) {
534 return undef if $noerr;
535 die "value does not look like a valid email address or user name\n";
540 register_format
('dns-name', \
&pve_verify_dns_name
);
541 sub pve_verify_dns_name
{
542 my ($name, $noerr) = @_;
544 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
546 if ($name !~ /^(${namere}\.)*${namere}$/) {
547 return undef if $noerr;
548 die "value does not look like a valid DNS name\n";
553 register_format
('timezone', \
&pve_verify_timezone
);
554 sub pve_verify_timezone
{
555 my ($timezone, $noerr) = @_;
557 return $timezone if $timezone eq 'UTC';
559 open(my $fh, "<", "/usr/share/zoneinfo/zone.tab");
560 while (my $line = <$fh>) {
561 next if $line =~ /^\s*#/;
563 my $zone = (split /\t/, $line)[2];
564 return $timezone if $timezone eq $zone; # found
568 return undef if $noerr;
569 die "invalid time zone '$timezone'\n";
572 # network interface name
573 register_format
('pve-iface', \
&pve_verify_iface
);
574 sub pve_verify_iface
{
575 my ($id, $noerr) = @_;
577 if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
578 return undef if $noerr;
579 die "invalid network interface name '$id'\n";
584 # general addresses by name or IP
585 register_format
('address', \
&pve_verify_address
);
586 sub pve_verify_address
{
587 my ($addr, $noerr) = @_;
589 if (!(pve_verify_ip
($addr, 1) ||
590 pve_verify_dns_name
($addr, 1)))
592 return undef if $noerr;
593 die "value does not look like a valid address: $addr\n";
598 register_format
('disk-size', \
&pve_verify_disk_size
);
599 sub pve_verify_disk_size
{
600 my ($size, $noerr) = @_;
601 if (!defined(parse_size
($size))) {
602 return undef if $noerr;
603 die "value does not look like a valid disk size: $size\n";
608 register_standard_option
('spice-proxy', {
609 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).",
610 type
=> 'string', format
=> 'address',
613 register_standard_option
('remote-viewer-config', {
614 description
=> "Returned values can be directly passed to the 'remote-viewer' application.",
615 additionalProperties
=> 1,
617 type
=> { type
=> 'string' },
618 password
=> { type
=> 'string' },
619 proxy
=> { type
=> 'string' },
620 host
=> { type
=> 'string' },
621 'tls-port' => { type
=> 'integer' },
625 register_format
('pve-startup-order', \
&pve_verify_startup_order
);
626 sub pve_verify_startup_order
{
627 my ($value, $noerr) = @_;
629 return $value if pve_parse_startup_order
($value);
631 return undef if $noerr;
633 die "unable to parse startup options\n";
638 type
=> 'number', minimum
=> '0',
639 format_description
=> 'LIMIT',
642 my $bwlimit_format = {
645 description
=> 'default bandwidth limit in KiB/s',
649 description
=> 'bandwidth limit in KiB/s for restoring guests from backups',
653 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)',
657 description
=> 'bandwidth limit in KiB/s for cloning disks',
661 description
=> 'bandwidth limit in KiB/s for moving disks',
664 register_format
('bwlimit', $bwlimit_format);
665 register_standard_option
('bwlimit', {
666 description
=> "Set bandwidth/io limits various operations.",
669 format
=> $bwlimit_format,
672 my $remote_format = {
675 format_description
=> 'Remote Proxmox hostname or IP',
683 format_description
=> 'A full Proxmox API token including the secret value.',
685 fingerprint
=> get_standard_option
(
686 'fingerprint-sha256',
689 format_description
=> 'Remote host\'s certificate fingerprint, if not trusted by system store.',
693 register_format
('proxmox-remote', $remote_format);
694 register_standard_option
('proxmox-remote', {
695 description
=> "Specification of a remote endpoint.",
696 type
=> 'string', format
=> 'proxmox-remote',
699 our $PVE_TAG_RE = qr/[a-z0-9_][a-z0-9_\-\+\.]*/i;
701 # used for pve-tag-list in e.g., guest configs
702 register_format
('pve-tag', \
&pve_verify_tag
);
704 my ($value, $noerr) = @_;
706 return $value if $value =~ m/^${PVE_TAG_RE}$/i;
708 return undef if $noerr;
710 die "invalid characters in tag\n";
713 sub pve_parse_startup_order
{
716 return undef if !$value;
720 foreach my $p (split(/,/, $value)) {
721 next if $p =~ m/^\s*$/;
723 if ($p =~ m/^(order=)?(\d+)$/) {
725 } elsif ($p =~ m/^up=(\d+)$/) {
727 } elsif ($p =~ m/^down=(\d+)$/) {
737 PVE
::JSONSchema
::register_standard_option
('pve-startup-order', {
738 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.",
740 type
=> 'string', format
=> 'pve-startup-order',
741 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ',
744 register_format
('pve-tfa-secret', \
&pve_verify_tfa_secret
);
745 sub pve_verify_tfa_secret
{
746 my ($key, $noerr) = @_;
748 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
749 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
750 # format to support arbitrary lengths properly:
751 if ($key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
752 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
753 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/) # and the old pattern copy&pasted
758 return undef if $noerr;
760 die "unable to decode TFA secret\n";
764 PVE
::JSONSchema
::register_format
('pve-task-status-type', \
&verify_task_status_type
);
765 sub verify_task_status_type
{
766 my ($value, $noerr) = @_;
768 return $value if $value =~ m/^(ok|error|warning|unknown)$/i;
770 return undef if $noerr;
772 die "invalid status '$value'\n";
776 my ($format, $value, $path) = @_;
778 if (ref($format) eq 'HASH') {
779 # hash ref cannot have validator/list/opt handling attached
780 return parse_property_string
($format, $value, $path);
783 if (ref($format) eq 'CODE') {
784 # we are the (sole, old-style) validator
785 return $format->($value);
788 return if $format eq 'regex';
791 $format =~ m/^(.*?)(?:-a?(list|opt))?$/;
792 my ($format_name, $format_type) = ($1, $2 // 'none');
793 my $registered = get_format
($format_name);
794 die "undefined format '$format'\n" if !$registered;
796 die "'-$format_type' format must have code ref, not hash\n"
797 if $format_type ne 'none' && ref($registered) ne 'CODE';
799 if ($format_type eq 'list') {
801 # Note: we allow empty lists
802 foreach my $v (split_list
($value)) {
803 push @{$parsed}, $registered->($v);
805 } elsif ($format_type eq 'opt') {
806 $parsed = $registered->($value) if $value;
808 if (ref($registered) eq 'HASH') {
809 # Note: this is the only case where a validator function could be
810 # attached, hence it's safe to handle that in parse_property_string.
811 # We do however have to call it with $format_name instead of
812 # $registered, so it knows about the name (and thus any validators).
813 $parsed = parse_property_string
($format, $value, $path);
815 $parsed = $registered->($value);
825 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
826 my ($size, $unit) = ($1, $3);
829 $size = $size * 1024;
830 } elsif ($unit eq 'M') {
831 $size = $size * 1024 * 1024;
832 } elsif ($unit eq 'G') {
833 $size = $size * 1024 * 1024 * 1024;
834 } elsif ($unit eq 'T') {
835 $size = $size * 1024 * 1024 * 1024 * 1024;
846 my $kb = int($size/1024);
847 return $size if $kb*1024 != $size;
849 my $mb = int($kb/1024);
850 return "${kb}K" if $mb*1024 != $kb;
852 my $gb = int($mb/1024);
853 return "${mb}M" if $gb*1024 != $mb;
855 my $tb = int($gb/1024);
856 return "${gb}G" if $tb*1024 != $gb;
863 return 1 if $bool =~ m/^(1|on|yes|true)$/i;
864 return 0 if $bool =~ m/^(0|off|no|false)$/i;
868 sub parse_property_string
{
869 my ($format, $data, $path, $additional_properties) = @_;
871 # In property strings we default to not allowing additional properties
872 $additional_properties = 0 if !defined($additional_properties);
874 # Support named formats here, too:
877 if (my $reg = get_format
($format)) {
878 die "parse_property_string only accepts hash based named formats\n"
879 if ref($reg) ne 'HASH';
881 # named formats can have validators attached
882 $validator = $format_validators->{$format};
886 die "unknown format: $format\n";
888 } elsif (ref($format) ne 'HASH') {
889 die "unexpected format value of type ".ref($format)."\n";
895 foreach my $part (split(/,/, $data)) {
896 next if $part =~ /^\s*$/;
898 if ($part =~ /^([^=]+)=(.+)$/) {
899 my ($k, $v) = ($1, $2);
900 die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
901 my $schema = $format->{$k};
902 if (my $alias = $schema->{alias
}) {
903 if (my $key_alias = $schema->{keyAlias
}) {
904 die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
905 $res->{$key_alias} = $k;
908 $schema = $format->{$k};
911 die "invalid key in comma-separated list property: $k\n" if !$schema;
912 if ($schema->{type
} && $schema->{type
} eq 'boolean') {
913 $v = parse_boolean
($v) // $v;
916 } elsif ($part !~ /=/) {
917 die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
918 foreach my $key (keys %$format) {
919 if ($format->{$key}->{default_key
}) {
921 if (!$res->{$default_key}) {
922 $res->{$default_key} = $part;
925 die "duplicate key in comma-separated list property: $default_key\n";
928 die "value without key, but schema does not define a default key\n" if !$default_key;
930 die "missing key in comma-separated list property\n";
935 check_object
($path, $format, $res, $additional_properties, $errors);
936 if (scalar(%$errors)) {
937 raise
"format error\n", errors
=> $errors;
940 return $validator->($res) if $validator;
945 my ($errors, $path, $msg) = @_;
947 $path = '_root' if !$path;
949 if ($errors->{$path}) {
950 $errors->{$path} = join ('\n', $errors->{$path}, $msg);
952 $errors->{$path} = $msg;
959 # see 'man perlretut'
960 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
966 return $value =~ m/^[+-]?\d+$/;
970 my ($path, $type, $value, $errors) = @_;
974 if (!defined($value)) {
975 return 1 if $type eq 'null';
979 if (my $tt = ref($type)) {
980 if ($tt eq 'ARRAY') {
981 foreach my $t (@$type) {
983 check_type
($path, $t, $value, $tmperr);
984 return 1 if !scalar(%$tmperr);
986 my $ttext = join ('|', @$type);
987 add_error
($errors, $path, "type check ('$ttext') failed");
989 } elsif ($tt eq 'HASH') {
991 check_prop
($value, $type, $path, $tmperr);
992 return 1 if !scalar(%$tmperr);
993 add_error
($errors, $path, "type check failed");
996 die "internal error - got reference type '$tt'";
1001 return 1 if $type eq 'any';
1003 if ($type eq 'null') {
1004 if (defined($value)) {
1005 add_error
($errors, $path, "type check ('$type') failed - value is not null");
1011 my $vt = ref($value);
1013 if ($type eq 'array') {
1014 if (!$vt || $vt ne 'ARRAY') {
1015 add_error
($errors, $path, "type check ('$type') failed");
1019 } elsif ($type eq 'object') {
1020 if (!$vt || $vt ne 'HASH') {
1021 add_error
($errors, $path, "type check ('$type') failed");
1025 } elsif ($type eq 'coderef') {
1026 if (!$vt || $vt ne 'CODE') {
1027 add_error
($errors, $path, "type check ('$type') failed");
1031 } elsif ($type eq 'string' && $vt eq 'Regexp') {
1032 # qr// regexes can be used as strings and make sense for format=regex
1036 add_error
($errors, $path, "type check ('$type') failed - got $vt");
1039 if ($type eq 'string') {
1040 return 1; # nothing to check ?
1041 } elsif ($type eq 'boolean') {
1042 #if ($value =~ m/^(1|true|yes|on)$/i) {
1043 if ($value eq '1') {
1045 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
1046 } elsif ($value eq '0') {
1047 return 1; # return success (not value)
1049 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1052 } elsif ($type eq 'integer') {
1053 if (!is_integer
($value)) {
1054 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1058 } elsif ($type eq 'number') {
1059 if (!is_number
($value)) {
1060 add_error
($errors, $path, "type check ('$type') failed - got '$value'");
1065 return 1; # no need to verify unknown types
1075 my ($path, $schema, $value, $additional_properties, $errors) = @_;
1077 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
1079 my $st = ref($schema);
1080 if (!$st || $st ne 'HASH') {
1081 add_error
($errors, $path, "Invalid schema definition.");
1085 my $vt = ref($value);
1086 if (!$vt || $vt ne 'HASH') {
1087 add_error
($errors, $path, "an object is required");
1091 foreach my $k (keys %$schema) {
1092 check_prop
($value->{$k}, $schema->{$k}, $path ?
"$path.$k" : $k, $errors);
1095 foreach my $k (keys %$value) {
1097 my $newpath = $path ?
"$path.$k" : $k;
1099 if (my $subschema = $schema->{$k}) {
1100 if (my $requires = $subschema->{requires
}) {
1101 if (ref($requires)) {
1102 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1103 check_prop
($value, $requires, $path, $errors);
1104 } elsif (!defined($value->{$requires})) {
1105 add_error
($errors, $path ?
"$path.$requires" : $requires,
1106 "missing property - '$newpath' requires this property");
1110 next; # value is already checked above
1113 if (defined ($additional_properties) && !$additional_properties) {
1114 add_error
($errors, $newpath, "property is not defined in schema " .
1115 "and the schema does not allow additional properties");
1118 check_prop
($value->{$k}, $additional_properties, $newpath, $errors)
1119 if ref($additional_properties);
1123 sub check_object_warn
{
1124 my ($path, $schema, $value, $additional_properties) = @_;
1126 check_object
($path, $schema, $value, $additional_properties, $errors);
1127 if (scalar(%$errors)) {
1128 foreach my $k (keys %$errors) {
1129 warn "parse error: $k: $errors->{$k}\n";
1137 my ($value, $schema, $path, $errors) = @_;
1139 die "internal error - no schema" if !$schema;
1140 die "internal error" if !$errors;
1142 #print "check_prop $path\n" if $value;
1144 my $st = ref($schema);
1145 if (!$st || $st ne 'HASH') {
1146 add_error
($errors, $path, "Invalid schema definition.");
1150 # if it extends another schema, it must pass that schema as well
1151 if($schema->{extends
}) {
1152 check_prop
($value, $schema->{extends
}, $path, $errors);
1155 if (!defined ($value)) {
1156 return if $schema->{type
} && $schema->{type
} eq 'null';
1157 if (!$schema->{optional
} && !$schema->{alias
} && !$schema->{group
}) {
1158 add_error
($errors, $path, "property is missing and it is not optional");
1163 return if !check_type
($path, $schema->{type
}, $value, $errors);
1165 if ($schema->{disallow
}) {
1167 if (check_type
($path, $schema->{disallow
}, $value, $tmperr)) {
1168 add_error
($errors, $path, "disallowed value was matched");
1173 if (my $vt = ref($value)) {
1175 if ($vt eq 'ARRAY') {
1176 if ($schema->{items
}) {
1177 my $it = ref($schema->{items
});
1178 if ($it && $it eq 'ARRAY') {
1179 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1180 die "not implemented";
1183 foreach my $el (@$value) {
1184 check_prop
($el, $schema->{items
}, "${path}[$ind]", $errors);
1190 } elsif ($schema->{properties
} || $schema->{additionalProperties
}) {
1191 check_object
($path, defined($schema->{properties
}) ?
$schema->{properties
} : {},
1192 $value, $schema->{additionalProperties
}, $errors);
1198 if (my $format = $schema->{format
}) {
1199 eval { check_format
($format, $value, $path); };
1201 add_error
($errors, $path, "invalid format - $@");
1206 if (my $pattern = $schema->{pattern
}) {
1207 if ($value !~ m/^$pattern$/) {
1208 add_error
($errors, $path, "value does not match the regex pattern");
1213 if (defined (my $max = $schema->{maxLength
})) {
1214 if (length($value) > $max) {
1215 add_error
($errors, $path, "value may only be $max characters long");
1220 if (defined (my $min = $schema->{minLength
})) {
1221 if (length($value) < $min) {
1222 add_error
($errors, $path, "value must be at least $min characters long");
1227 if (is_number
($value)) {
1228 if (defined (my $max = $schema->{maximum
})) {
1229 if ($value > $max) {
1230 add_error
($errors, $path, "value must have a maximum value of $max");
1235 if (defined (my $min = $schema->{minimum
})) {
1236 if ($value < $min) {
1237 add_error
($errors, $path, "value must have a minimum value of $min");
1243 if (my $ea = $schema->{enum
}) {
1246 foreach my $ev (@$ea) {
1247 if ($ev eq $value) {
1253 add_error
($errors, $path, "value '$value' does not have a value in the enumeration '" .
1254 join(", ", @$ea) . "'");
1261 my ($instance, $schema, $errmsg) = @_;
1264 $errmsg = "Parameter verification failed.\n" if !$errmsg;
1266 # todo: cycle detection is only needed for debugging, I guess
1267 # we can disable that in the final release
1268 # todo: is there a better/faster way to detect cycles?
1270 # 'download' responses can contain a filehandle, don't cycle-check that as
1271 # it produces a warning
1272 my $is_download = ref($instance) eq 'HASH' && exists($instance->{download
});
1273 find_cycle
($instance, sub { $cycles = 1 }) if !$is_download;
1275 add_error
($errors, undef, "data structure contains recursive cycles");
1277 check_prop
($instance, $schema, '', $errors);
1280 if (scalar(%$errors)) {
1281 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors;
1287 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
1288 my $default_schema_noref = {
1289 description
=> "This is the JSON Schema for JSON Schemas.",
1290 type
=> [ "object" ],
1291 additionalProperties
=> 0,
1294 type
=> ["string", "array"],
1295 description
=> "This is a type definition value. This can be a simple type, or a union type",
1300 enum
=> $schema_valid_types,
1302 enum
=> $schema_valid_types,
1306 description
=> "This indicates that the instance property in the instance object is not required.",
1312 description
=> "This is a definition for the properties of an object value",
1318 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array",
1322 additionalProperties
=> {
1323 type
=> [ "boolean", "object"],
1324 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
1331 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number.",
1336 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number.",
1340 description
=> "When the instance value is a string, this indicates minimum length of the string",
1347 description
=> "When the instance value is a string, this indicates maximum length of the string.",
1353 description
=> "A text representation of the type (used to generate documentation).",
1358 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.",
1365 description
=> "This provides an enumeration of possible values that are valid for the instance property.",
1370 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).",
1372 verbose_description
=> {
1375 description
=> "This provides a more verbose description.",
1377 format_description
=> {
1380 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1385 description
=> "This provides the title of the property",
1390 description
=> "This is used to provide rendering hints to format cli command output.",
1393 type
=> [ "string", "object" ],
1395 description
=> "indicates a required property or a schema that must be validated if this property is present",
1398 type
=> [ "string", "object" ],
1400 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",
1405 description
=> "Whether this is the default key in a comma separated list property string.",
1410 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.",
1415 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1416 requires
=> 'alias',
1421 description
=> "This indicates the default for the instance property."
1425 description
=> "Bash completion function. This function should return a list of possible values.",
1431 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.",
1436 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1439 # this is from hyper schema
1442 description
=> "This defines the link relations of the instance objects",
1449 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",
1453 description
=> "This is the name of the link relation",
1459 description
=> "For submission links, this defines the method that should be used to access the target resource",
1468 description
=> "For CLI context, this defines the maximal width to print before truncating",
1474 my $default_schema = Storable
::dclone
($default_schema_noref);
1476 $default_schema->{properties
}->{properties
}->{additionalProperties
} = $default_schema;
1477 $default_schema->{properties
}->{additionalProperties
}->{properties
} = $default_schema->{properties
};
1479 $default_schema->{properties
}->{items
}->{properties
} = $default_schema->{properties
};
1480 $default_schema->{properties
}->{items
}->{additionalProperties
} = 0;
1482 $default_schema->{properties
}->{disallow
}->{properties
} = $default_schema->{properties
};
1483 $default_schema->{properties
}->{disallow
}->{additionalProperties
} = 0;
1485 $default_schema->{properties
}->{requires
}->{properties
} = $default_schema->{properties
};
1486 $default_schema->{properties
}->{requires
}->{additionalProperties
} = 0;
1488 $default_schema->{properties
}->{extends
}->{properties
} = $default_schema->{properties
};
1489 $default_schema->{properties
}->{extends
}->{additionalProperties
} = 0;
1491 my $method_schema = {
1493 additionalProperties
=> 0,
1496 description
=> "This a description of the method",
1501 description
=> "This indicates the name of the function to call.",
1504 additionalProperties
=> 1,
1519 description
=> "The HTTP method name.",
1520 enum
=> [ 'GET', 'POST', 'PUT', 'DELETE' ],
1525 description
=> "Method needs special privileges - only pvedaemon can execute it",
1530 description
=> "Method is available for clients authenticated using an API token.",
1536 description
=> "Method downloads the file content (filename is the return value of the method).",
1541 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1544 proxyto_callback
=> {
1546 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter.",
1551 description
=> "Required access permissions. By default only 'root' is allowed to access this method.",
1553 additionalProperties
=> 0,
1556 description
=> "Describe access permissions.",
1560 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
1562 enum
=> ['all', 'world'],
1566 description
=> "Array of permission checks (prefix notation).",
1573 description
=> "Used internally",
1577 description
=> "Used internally",
1582 description
=> "path for URL matching (uri template)",
1584 fragmentDelimiter
=> {
1586 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.",
1591 description
=> "JSON Schema for parameters.",
1596 description
=> "JSON Schema for return value.",
1601 description
=> "method implementation (code reference)",
1606 description
=> "Delegate call to this class (perl class string).",
1609 additionalProperties
=> 0,
1615 fragmentDelimiter
=> { optional
=> 1 }
1623 sub validate_schema
{
1626 my $errmsg = "internal error - unable to verify schema\n";
1627 validate
($schema, $default_schema, $errmsg);
1630 sub validate_method_info
{
1633 my $errmsg = "internal error - unable to verify method info\n";
1634 validate
($info, $method_schema, $errmsg);
1636 validate_schema
($info->{parameters
}) if $info->{parameters
};
1637 validate_schema
($info->{returns
}) if $info->{returns
};
1640 # run a self test on load
1641 # make sure we can verify the default schema
1642 validate_schema
($default_schema_noref);
1643 validate_schema
($method_schema);
1645 # and now some utility methods (used by pve api)
1646 sub method_get_child_link
{
1649 return undef if !$info;
1651 my $schema = $info->{returns
};
1652 return undef if !$schema || !$schema->{type
} || $schema->{type
} ne 'array';
1654 my $links = $schema->{links
};
1655 return undef if !$links;
1658 foreach my $lnk (@$links) {
1659 if ($lnk->{href
} && $lnk->{rel
} && ($lnk->{rel
} eq 'child')) {
1668 # a way to parse command line parameters, using a
1669 # schema to configure Getopt::Long
1671 my ($schema, $args, $arg_param, $fixed_param, $param_mapping_hash) = @_;
1673 if (!$schema || !$schema->{properties
}) {
1674 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1675 if scalar(@$args) != 0;
1680 if ($arg_param && !ref($arg_param)) {
1681 my $pd = $schema->{properties
}->{$arg_param};
1682 die "expected list format $pd->{format}"
1683 if !($pd && $pd->{format
} && $pd->{format
} =~ m/-list/);
1684 $list_param = $arg_param;
1687 my @interactive = ();
1689 foreach my $prop (keys %{$schema->{properties
}}) {
1690 my $pd = $schema->{properties
}->{$prop};
1691 next if $list_param && $prop eq $list_param;
1692 next if defined($fixed_param->{$prop});
1694 my $mapping = $param_mapping_hash->{$prop};
1695 if ($mapping && $mapping->{interactive
}) {
1696 # interactive parameters such as passwords: make the argument
1697 # optional and call the mapping function afterwards.
1698 push @getopt, "$prop:s";
1699 push @interactive, [$prop, $mapping->{func
}];
1700 } elsif ($pd->{type
} eq 'boolean') {
1701 push @getopt, "$prop:s";
1703 if ($pd->{format
} && $pd->{format
} =~ m/-a?list/) {
1704 push @getopt, "$prop=s@";
1706 push @getopt, "$prop=s";
1711 Getopt
::Long
::Configure
('prefix_pattern=(--|-)');
1714 raise
("unable to parse option\n", code
=> HTTP_BAD_REQUEST
)
1715 if !Getopt
::Long
::GetOptionsFromArray
($args, $opts, @getopt);
1719 $opts->{$list_param} = $args;
1721 } elsif (ref($arg_param)) {
1722 for (my $i = 0; $i < scalar(@$arg_param); $i++) {
1723 my $arg_name = $arg_param->[$i];
1724 if ($opts->{'extra-args'}) {
1725 raise
("internal error: extra-args must be the last argument\n", code
=> HTTP_BAD_REQUEST
);
1727 if ($arg_name eq 'extra-args') {
1728 $opts->{'extra-args'} = $args;
1733 # check if all left-over arg_param are optional, else we
1734 # must die as the mapping is then ambigious
1735 for (; $i < scalar(@$arg_param); $i++) {
1736 my $prop = $arg_param->[$i];
1737 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
)
1738 if !$schema->{properties
}->{$prop}->{optional
};
1740 if ($arg_param->[-1] eq 'extra-args') {
1741 $opts->{'extra-args'} = [];
1745 $opts->{$arg_name} = shift @$args;
1747 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
) if @$args;
1749 raise
("too many arguments\n", code
=> HTTP_BAD_REQUEST
)
1750 if scalar(@$args) != 0;
1753 if (ref($arg_param)) {
1754 foreach my $arg_name (@$arg_param) {
1755 if ($arg_name eq 'extra-args') {
1756 $opts->{'extra-args'} = [];
1757 } elsif (!$schema->{properties
}->{$arg_name}->{optional
}) {
1758 raise
("not enough arguments\n", code
=> HTTP_BAD_REQUEST
);
1764 foreach my $entry (@interactive) {
1765 my ($opt, $func) = @$entry;
1766 my $pd = $schema->{properties
}->{$opt};
1767 my $value = $opts->{$opt};
1768 if (defined($value) || !$pd->{optional
}) {
1769 $opts->{$opt} = $func->($value);
1773 # decode after Getopt as we are not sure how well it handles unicode
1774 foreach my $p (keys %$opts) {
1775 if (!ref($opts->{$p})) {
1776 $opts->{$p} = decode
('locale', $opts->{$p});
1777 } elsif (ref($opts->{$p}) eq 'ARRAY') {
1779 foreach my $v (@{$opts->{$p}}) {
1780 push @$tmp, decode
('locale', $v);
1783 } elsif (ref($opts->{$p}) eq 'SCALAR') {
1784 $opts->{$p} = decode
('locale', $$opts->{$p});
1786 raise
("decoding options failed, unknown reference\n", code
=> HTTP_BAD_REQUEST
);
1790 foreach my $p (keys %$opts) {
1791 if (my $pd = $schema->{properties
}->{$p}) {
1792 if ($pd->{type
} eq 'boolean') {
1793 if ($opts->{$p} eq '') {
1795 } elsif (defined(my $bool = parse_boolean
($opts->{$p}))) {
1796 $opts->{$p} = $bool;
1798 raise
("unable to parse boolean option\n", code
=> HTTP_BAD_REQUEST
);
1800 } elsif ($pd->{format
}) {
1802 if ($pd->{format
} =~ m/-list/) {
1803 # allow --vmid 100 --vmid 101 and --vmid 100,101
1804 # allow --dow mon --dow fri and --dow mon,fri
1805 $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1806 } elsif ($pd->{format
} =~ m/-alist/) {
1807 # we encode array as \0 separated strings
1808 # Note: CGI.pm also use this encoding
1809 if (scalar(@{$opts->{$p}}) != 1) {
1810 $opts->{$p} = join("\0", @{$opts->{$p}});
1812 # st that split_list knows it is \0 terminated
1813 my $v = $opts->{$p}->[0];
1814 $opts->{$p} = "$v\0";
1821 foreach my $p (keys %$fixed_param) {
1822 $opts->{$p} = $fixed_param->{$p};
1828 # A way to parse configuration data by giving a json schema
1829 sub parse_config
: prototype($$$;$) {
1830 my ($schema, $filename, $raw, $comment_key) = @_;
1832 # do fast check (avoid validate_schema($schema))
1833 die "got strange schema" if !$schema->{type
} ||
1834 !$schema->{properties
} || $schema->{type
} ne 'object';
1839 my $handle_comment = sub { $_[0] =~ /^#/ };
1840 if (defined($comment_key)) {
1842 my $comment_re = qr/^\Q$comment_key\E:\s*(.*\S)\s*$/;
1843 $handle_comment = sub {
1844 if ($_[0] =~ /^\#(.*)\s*$/ || $_[0] =~ $comment_re) {
1845 $comment_data .= PVE
::Tools
::decode_text
($1) . "\n";
1852 while ($raw =~ /^\s*(.+?)\s*$/gm) {
1855 next if $handle_comment->($line);
1857 if ($line =~ m/^(\S+?):\s*(.*)$/) {
1860 if ($schema->{properties
}->{$key} &&
1861 $schema->{properties
}->{$key}->{type
} eq 'boolean') {
1863 $value = parse_boolean
($value) // $value;
1865 $cfg->{$key} = $value;
1867 warn "ignore config line: $line\n"
1871 if (defined($comment_data)) {
1872 $cfg->{$comment_key} = $comment_data;
1876 check_prop
($cfg, $schema, '', $errors);
1878 foreach my $k (keys %$errors) {
1879 warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1886 # generate simple key/value file
1888 my ($schema, $filename, $cfg) = @_;
1890 # do fast check (avoid validate_schema($schema))
1891 die "got strange schema" if !$schema->{type
} ||
1892 !$schema->{properties
} || $schema->{type
} ne 'object';
1894 validate
($cfg, $schema, "validation error in '$filename'\n");
1898 foreach my $k (sort keys %$cfg) {
1899 $data .= "$k: $cfg->{$k}\n";
1905 # helpers used to generate our manual pages
1907 my $find_schema_default_key = sub {
1911 my $keyAliasProps = {};
1913 foreach my $key (keys %$format) {
1914 my $phash = $format->{$key};
1915 if ($phash->{default_key
}) {
1916 die "multiple default keys in schema ($default_key, $key)\n"
1917 if defined($default_key);
1918 die "default key '$key' is an alias - this is not allowed\n"
1919 if defined($phash->{alias
});
1920 die "default key '$key' with keyAlias attribute is not allowed\n"
1921 if $phash->{keyAlias
};
1922 $default_key = $key;
1924 my $key_alias = $phash->{keyAlias
};
1925 die "found keyAlias without 'alias definition for '$key'\n"
1926 if $key_alias && !$phash->{alias
};
1928 if ($phash->{alias
} && $key_alias) {
1929 die "inconsistent keyAlias '$key_alias' definition"
1930 if defined($keyAliasProps->{$key_alias}) &&
1931 $keyAliasProps->{$key_alias} ne $phash->{alias
};
1932 $keyAliasProps->{$key_alias} = $phash->{alias
};
1936 return wantarray ?
($default_key, $keyAliasProps) : $default_key;
1939 sub generate_typetext
{
1940 my ($format, $list_enums) = @_;
1942 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1947 my $add_option_string = sub {
1948 my ($text, $optional) = @_;
1954 $text = "[$text]" if $optional;
1959 my $format_key_value = sub {
1960 my ($key, $phash) = @_;
1962 die "internal error" if defined($phash->{alias
});
1968 if (my $desc = $phash->{format_description
}) {
1969 $typetext .= "<$desc>";
1970 } elsif (my $text = $phash->{typetext
}) {
1972 } elsif (my $enum = $phash->{enum
}) {
1973 if ($list_enums || (scalar(@$enum) <= 3)) {
1974 $typetext .= '<' . join('|', @$enum) . '>';
1976 $typetext .= '<enum>';
1978 } elsif ($phash->{type
} eq 'boolean') {
1979 $typetext .= '<1|0>';
1980 } elsif ($phash->{type
} eq 'integer') {
1981 $typetext .= '<integer>';
1982 } elsif ($phash->{type
} eq 'number') {
1983 $typetext .= '<number>';
1985 die "internal error: neither format_description nor typetext found for option '$key'";
1988 if (defined($default_key) && ($default_key eq $key)) {
1989 &$add_option_string("[$keytext=]$typetext", $phash->{optional
});
1991 &$add_option_string("$keytext=$typetext", $phash->{optional
});
1997 my $cond_add_key = sub {
2000 return if $done->{$key}; # avoid duplicates
2004 my $phash = $format->{$key};
2006 return if !$phash; # should not happen
2008 return if $phash->{alias
};
2010 &$format_key_value($key, $phash);
2014 &$cond_add_key($default_key) if defined($default_key);
2016 # add required keys first
2017 foreach my $key (sort keys %$format) {
2018 my $phash = $format->{$key};
2019 &$cond_add_key($key) if $phash && !$phash->{optional
};
2023 foreach my $key (sort keys %$format) {
2024 &$cond_add_key($key);
2027 foreach my $keyAlias (sort keys %$keyAliasProps) {
2028 &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
2034 sub print_property_string
{
2035 my ($data, $format, $skip, $path) = @_;
2038 if (ref($format) ne 'HASH') {
2039 my $schema = get_format
($format);
2040 die "not a valid format: $format\n" if !$schema;
2041 # named formats can have validators attached
2042 $validator = $format_validators->{$format};
2047 check_object
($path, $format, $data, undef, $errors);
2048 if (scalar(%$errors)) {
2049 raise
"format error", errors
=> $errors;
2052 $data = $validator->($data) if $validator;
2054 my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
2059 my $add_option_string = sub {
2062 $res .= ',' if $add_sep;
2067 my $format_value = sub {
2068 my ($key, $value, $format) = @_;
2070 if (defined($format) && ($format eq 'disk-size')) {
2071 return format_size
($value);
2073 die "illegal value with commas for $key\n" if $value =~ /,/;
2078 my $done = { map { $_ => 1 } @$skip };
2080 my $cond_add_key = sub {
2081 my ($key, $isdefault) = @_;
2083 return if $done->{$key}; # avoid duplicates
2087 my $value = $data->{$key};
2089 return if !defined($value);
2091 my $phash = $format->{$key};
2093 # try to combine values if we have key aliases
2094 if (my $combine = $keyAliasProps->{$key}) {
2095 if (defined(my $combine_value = $data->{$combine})) {
2096 my $combine_format = $format->{$combine}->{format
};
2097 my $value_str = &$format_value($key, $value, $phash->{format
});
2098 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
2099 &$add_option_string("${value_str}=${combine_str}");
2100 $done->{$combine} = 1;
2105 if ($phash && $phash->{alias
}) {
2106 $phash = $format->{$phash->{alias
}};
2109 die "invalid key '$key'\n" if !$phash;
2110 die "internal error" if defined($phash->{alias
});
2112 my $value_str = &$format_value($key, $value, $phash->{format
});
2114 &$add_option_string($value_str);
2116 &$add_option_string("$key=${value_str}");
2120 # add default key first
2121 &$cond_add_key($default_key, 1) if defined($default_key);
2123 # add required keys first
2124 foreach my $key (sort keys %$data) {
2125 my $phash = $format->{$key};
2126 &$cond_add_key($key) if $phash && !$phash->{optional
};
2130 foreach my $key (sort keys %$data) {
2131 &$cond_add_key($key);
2137 sub schema_get_type_text
{
2138 my ($phash, $style) = @_;
2140 my $type = $phash->{type
} || 'string';
2142 if ($phash->{typetext
}) {
2143 return $phash->{typetext
};
2144 } elsif ($phash->{format_description
}) {
2145 return "<$phash->{format_description}>";
2146 } elsif ($phash->{enum
}) {
2147 return "<" . join(' | ', sort @{$phash->{enum
}}) . ">";
2148 } elsif ($phash->{pattern
}) {
2149 return $phash->{pattern
};
2150 } elsif ($type eq 'integer' || $type eq 'number') {
2151 # NOTE: always access values as number (avoid converion to string)
2152 if (defined($phash->{minimum
}) && defined($phash->{maximum
})) {
2153 return "<$type> (" . ($phash->{minimum
} + 0) . " - " .
2154 ($phash->{maximum
} + 0) . ")";
2155 } elsif (defined($phash->{minimum
})) {
2156 return "<$type> (" . ($phash->{minimum
} + 0) . " - N)";
2157 } elsif (defined($phash->{maximum
})) {
2158 return "<$type> (-N - " . ($phash->{maximum
} + 0) . ")";
2160 } elsif ($type eq 'string') {
2161 if (my $format = $phash->{format
}) {
2162 $format = get_format
($format) if ref($format) ne 'HASH';
2163 if (ref($format) eq 'HASH') {
2165 $list_enums = 1 if $style && $style eq 'config-sub';
2166 return generate_typetext
($format, $list_enums);