]>
git.proxmox.com Git - pve-common.git/blob - src/PVE/JSONSchema.pm
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
23 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
24 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
25 # see: http://json-schema.org/
27 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
29 my $standard_options = {};
30 sub register_standard_option
{
31 my ( $name, $schema ) = @_ ;
33 die "standard option ' $name ' already registered \n "
34 if $standard_options ->{ $name };
36 $standard_options ->{ $name } = $schema ;
39 sub get_standard_option
{
40 my ( $name, $base ) = @_ ;
42 my $std = $standard_options ->{ $name };
43 die "no such standard option ' $name ' \n " if ! $std ;
45 my $res = $base || {};
47 foreach my $opt ( keys %$std ) {
48 next if defined ( $res ->{ $opt });
49 $res ->{ $opt } = $std ->{ $opt };
55 register_standard_option
( 'pve-vmid' , {
56 description
=> "The (unique) ID of the VM." ,
57 type
=> 'integer' , format
=> 'pve-vmid' ,
61 register_standard_option
( 'pve-node' , {
62 description
=> "The cluster node name." ,
63 type
=> 'string' , format
=> 'pve-node' ,
66 register_standard_option
( 'pve-node-list' , {
67 description
=> "List of cluster node names." ,
68 type
=> 'string' , format
=> 'pve-node-list' ,
71 register_standard_option
( 'pve-iface' , {
72 description
=> "Network interface name." ,
73 type
=> 'string' , format
=> 'pve-iface' ,
74 minLength
=> 2 , maxLength
=> 20 ,
77 register_standard_option
( 'pve-storage-id' , {
78 description
=> "The storage identifier." ,
79 type
=> 'string' , format
=> 'pve-storage-id' ,
82 register_standard_option
( 'pve-config-digest' , {
83 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.' ,
86 maxLength
=> 40 , # sha1 hex digest length is 40
89 register_standard_option
( 'skiplock' , {
90 description
=> "Ignore locks - only root is allowed to use this option." ,
95 register_standard_option
( 'extra-args' , {
96 description
=> "Extra arguments as array" ,
98 items
=> { type
=> 'string' },
102 register_standard_option
( 'fingerprint-sha256' , {
103 description
=> "Certificate SHA 256 fingerprint." ,
105 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}' ,
108 register_standard_option
( 'pve-output-format' , {
110 description
=> 'Output format.' ,
111 enum
=> [ 'text' , 'json' , 'json-pretty' , 'yaml' ],
116 register_standard_option
( 'pve-snapshot-name' , {
117 description
=> "The name of the snapshot." ,
118 type
=> 'string' , format
=> 'pve-configid' ,
122 my $format_list = {};
124 sub register_format
{
125 my ( $format, $code ) = @_ ;
127 die "JSON schema format ' $format ' already registered \n "
128 if $format_list ->{ $format };
130 $format_list ->{ $format } = $code ;
135 return $format_list ->{ $format };
138 my $renderer_hash = {};
140 sub register_renderer
{
141 my ( $name, $code ) = @_ ;
143 die "renderer ' $name ' already registered \n "
144 if $renderer_hash ->{ $name };
146 $renderer_hash ->{ $name } = $code ;
151 return $renderer_hash ->{ $name };
154 # register some common type for pve
156 register_format
( 'string' , sub {}); # allow format => 'string-list'
158 register_format
( 'urlencoded' , \
& pve_verify_urlencoded
);
159 sub pve_verify_urlencoded
{
160 my ( $text, $noerr ) = @_ ;
161 if ( $text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/ ) {
162 return undef if $noerr ;
163 die "invalid urlencoded string: $text\n " ;
168 register_format
( 'pve-configid' , \
& pve_verify_configid
);
169 sub pve_verify_configid
{
170 my ( $id, $noerr ) = @_ ;
172 if ( $id !~ m/^[a-z][a-z0-9_]+$/i ) {
173 return undef if $noerr ;
174 die "invalid configuration ID ' $id ' \n " ;
179 PVE
:: JSONSchema
:: register_format
( 'pve-storage-id' , \
& parse_storage_id
);
180 sub parse_storage_id
{
181 my ( $storeid, $noerr ) = @_ ;
183 if ( $storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
184 return undef if $noerr ;
185 die "storage ID ' $storeid ' contains illegal characters \n " ;
191 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
192 sub pve_verify_vmid
{
193 my ( $vmid, $noerr ) = @_ ;
195 if ( $vmid !~ m/^[1-9][0-9]{2,8}$/ ) {
196 return undef if $noerr ;
197 die "value does not look like a valid VM ID \n " ;
202 register_format
( 'pve-node' , \
& pve_verify_node_name
);
203 sub pve_verify_node_name
{
204 my ( $node, $noerr ) = @_ ;
206 if ( $node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/ ) {
207 return undef if $noerr ;
208 die "value does not look like a valid node name \n " ;
213 register_format
( 'mac-addr' , \
& pve_verify_mac_addr
);
214 sub pve_verify_mac_addr
{
215 my ( $mac_addr, $noerr ) = @_ ;
217 # don't allow I/G bit to be set, most of the time it breaks things, see:
218 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
219 if ( $mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i ) {
220 return undef if $noerr ;
221 die "value does not look like a valid unicast MAC address \n " ;
226 register_standard_option
( 'mac-addr' , {
228 description
=> 'Unicast MAC address.' ,
229 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.' ,
230 format_description
=> "XX:XX:XX:XX:XX:XX" ,
232 format
=> 'mac-addr' ,
235 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
236 sub pve_verify_ipv4
{
237 my ( $ipv4, $noerr ) = @_ ;
239 if ( $ipv4 !~ m/^(?:$IPV4RE)$/ ) {
240 return undef if $noerr ;
241 die "value does not look like a valid IPv4 address \n " ;
246 register_format
( 'ipv6' , \
& pve_verify_ipv6
);
247 sub pve_verify_ipv6
{
248 my ( $ipv6, $noerr ) = @_ ;
250 if ( $ipv6 !~ m/^(?:$IPV6RE)$/ ) {
251 return undef if $noerr ;
252 die "value does not look like a valid IPv6 address \n " ;
257 register_format
( 'ip' , \
& pve_verify_ip
);
259 my ( $ip, $noerr ) = @_ ;
261 if ( $ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/ ) {
262 return undef if $noerr ;
263 die "value does not look like a valid IP address \n " ;
268 PVE
:: JSONSchema
:: register_format
( 'ldap-simple-attr' , \
& verify_ldap_simple_attr
);
269 sub verify_ldap_simple_attr
{
270 my ( $attr, $noerr ) = @_ ;
272 if ( $attr =~ m/^[a-zA-Z0-9]+$/ ) {
276 die "value ' $attr ' does not look like a simple ldap attribute name \n " if ! $noerr ;
281 my $ipv4_mask_hash = {
299 '255.255.128.0' => 17 ,
300 '255.255.192.0' => 18 ,
301 '255.255.224.0' => 19 ,
302 '255.255.240.0' => 20 ,
303 '255.255.248.0' => 21 ,
304 '255.255.252.0' => 22 ,
305 '255.255.254.0' => 23 ,
306 '255.255.255.0' => 24 ,
307 '255.255.255.128' => 25 ,
308 '255.255.255.192' => 26 ,
309 '255.255.255.224' => 27 ,
310 '255.255.255.240' => 28 ,
311 '255.255.255.248' => 29 ,
312 '255.255.255.252' => 30 ,
313 '255.255.255.254' => 31 ,
314 '255.255.255.255' => 32 ,
317 sub get_netmask_bits
{
319 return $ipv4_mask_hash ->{ $mask };
322 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
323 sub pve_verify_ipv4mask
{
324 my ( $mask, $noerr ) = @_ ;
326 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
327 return undef if $noerr ;
328 die "value does not look like a valid IP netmask \n " ;
333 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
334 sub pve_verify_cidrv6
{
335 my ( $cidr, $noerr ) = @_ ;
337 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
341 return undef if $noerr ;
342 die "value does not look like a valid IPv6 CIDR network \n " ;
345 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
346 sub pve_verify_cidrv4
{
347 my ( $cidr, $noerr ) = @_ ;
349 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
353 return undef if $noerr ;
354 die "value does not look like a valid IPv4 CIDR network \n " ;
357 register_format
( 'CIDR' , \
& pve_verify_cidr
);
358 sub pve_verify_cidr
{
359 my ( $cidr, $noerr ) = @_ ;
361 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
362 pve_verify_cidrv6
( $cidr, 1 )))
364 return undef if $noerr ;
365 die "value does not look like a valid CIDR network \n " ;
371 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
372 sub pve_verify_ipv4_config
{
373 my ( $config, $noerr ) = @_ ;
375 return $config if $config =~ /^(?:dhcp|manual)$/ ||
376 pve_verify_cidrv4
( $config, 1 );
377 return undef if $noerr ;
378 die "value does not look like a valid ipv4 network configuration \n " ;
381 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
382 sub pve_verify_ipv6_config
{
383 my ( $config, $noerr ) = @_ ;
385 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
386 pve_verify_cidrv6
( $config, 1 );
387 return undef if $noerr ;
388 die "value does not look like a valid ipv6 network configuration \n " ;
391 register_format
( 'email' , \
& pve_verify_email
);
392 sub pve_verify_email
{
393 my ( $email, $noerr ) = @_ ;
395 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
396 return undef if $noerr ;
397 die "value does not look like a valid email address \n " ;
402 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
403 sub pve_verify_dns_name
{
404 my ( $name, $noerr ) = @_ ;
406 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
408 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
409 return undef if $noerr ;
410 die "value does not look like a valid DNS name \n " ;
415 # network interface name
416 register_format
( 'pve-iface' , \
& pve_verify_iface
);
417 sub pve_verify_iface
{
418 my ( $id, $noerr ) = @_ ;
420 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
421 return undef if $noerr ;
422 die "invalid network interface name ' $id ' \n " ;
427 # general addresses by name or IP
428 register_format
( 'address' , \
& pve_verify_address
);
429 sub pve_verify_address
{
430 my ( $addr, $noerr ) = @_ ;
432 if (!( pve_verify_ip
( $addr, 1 ) ||
433 pve_verify_dns_name
( $addr, 1 )))
435 return undef if $noerr ;
436 die "value does not look like a valid address: $addr\n " ;
441 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
442 sub pve_verify_disk_size
{
443 my ( $size, $noerr ) = @_ ;
444 if (! defined ( parse_size
( $size ))) {
445 return undef if $noerr ;
446 die "value does not look like a valid disk size: $size\n " ;
451 register_standard_option
( 'spice-proxy' , {
452 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)." ,
453 type
=> 'string' , format
=> 'address' ,
456 register_standard_option
( 'remote-viewer-config' , {
457 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
458 additionalProperties
=> 1 ,
460 type
=> { type
=> 'string' },
461 password
=> { type
=> 'string' },
462 proxy
=> { type
=> 'string' },
463 host
=> { type
=> 'string' },
464 'tls-port' => { type
=> 'integer' },
468 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
469 sub pve_verify_startup_order
{
470 my ( $value, $noerr ) = @_ ;
472 return $value if pve_parse_startup_order
( $value );
474 return undef if $noerr ;
476 die "unable to parse startup options \n " ;
481 type
=> 'number' , minimum
=> '0' ,
482 format_description
=> 'LIMIT' ,
485 my $bwlimit_format = {
488 description
=> 'default bandwidth limit in KiB/s' ,
492 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
496 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
500 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
504 description
=> 'bandwidth limit in KiB/s for moving disks' ,
507 register_format
( 'bwlimit' , $bwlimit_format );
508 register_standard_option
( 'bwlimit' , {
509 description
=> "Set bandwidth/io limits various operations." ,
512 format
=> $bwlimit_format,
515 # used for pve-tag-list in e.g., guest configs
516 register_format
( 'pve-tag' , \
& pve_verify_tag
);
518 my ( $value, $noerr ) = @_ ;
520 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i ;
522 return undef if $noerr ;
524 die "invalid characters in tag \n " ;
527 sub pve_parse_startup_order
{
530 return undef if ! $value ;
534 foreach my $p ( split ( /,/ , $value )) {
535 next if $p =~ m/^\s*$/ ;
537 if ( $p =~ m/^(order=)?(\d+)$/ ) {
539 } elsif ( $p =~ m/^up=(\d+)$/ ) {
541 } elsif ( $p =~ m/^down=(\d+)$/ ) {
551 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
552 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." ,
554 type
=> 'string' , format
=> 'pve-startup-order' ,
555 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
558 register_format
( 'pve-tfa-secret' , \
& pve_verify_tfa_secret
);
559 sub pve_verify_tfa_secret
{
560 my ( $key, $noerr ) = @_ ;
562 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
563 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
564 # format to support arbitrary lengths properly:
565 if ( $key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
566 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
567 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/ ) # and the old pattern copy&pasted
572 return undef if $noerr ;
574 die "unable to decode TFA secret \n " ;
578 my ( $format, $value, $path ) = @_ ;
580 return parse_property_string
( $format, $value, $path ) if ref ( $format ) eq 'HASH' ;
581 return if $format eq 'regex' ;
583 if ( $format =~ m/^(.*)-a?list$/ ) {
585 my $code = $format_list ->{ $1 };
587 die "undefined format ' $format ' \n " if ! $code ;
589 # Note: we allow empty lists
590 foreach my $v ( split_list
( $value )) {
594 } elsif ( $format =~ m/^(.*)-opt$/ ) {
596 my $code = $format_list ->{ $1 };
598 die "undefined format ' $format ' \n " if ! $code ;
600 return if ! $value ; # allow empty string
606 my $code = $format_list ->{ $format };
608 die "undefined format ' $format ' \n " if ! $code ;
610 return parse_property_string
( $code, $value, $path ) if ref ( $code ) eq 'HASH' ;
618 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
619 my ( $size, $unit ) = ( $1, $3 );
622 $size = $size * 1024 ;
623 } elsif ( $unit eq 'M' ) {
624 $size = $size * 1024 * 1024 ;
625 } elsif ( $unit eq 'G' ) {
626 $size = $size * 1024 * 1024 * 1024 ;
627 } elsif ( $unit eq 'T' ) {
628 $size = $size * 1024 * 1024 * 1024 * 1024 ;
639 my $kb = int ( $size/1024 );
640 return $size if $kb*1024 != $size ;
642 my $mb = int ( $kb/1024 );
643 return "${kb}K" if $mb*1024 != $kb ;
645 my $gb = int ( $mb/1024 );
646 return "${mb}M" if $gb*1024 != $mb ;
648 my $tb = int ( $gb/1024 );
649 return "${gb}G" if $tb*1024 != $gb ;
656 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
657 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
661 sub parse_property_string
{
662 my ( $format, $data, $path, $additional_properties ) = @_ ;
664 # In property strings we default to not allowing additional properties
665 $additional_properties = 0 if ! defined ( $additional_properties );
667 # Support named formats here, too:
669 if ( my $desc = $format_list ->{ $format }) {
672 die "unknown format: $format\n " ;
674 } elsif ( ref ( $format ) ne 'HASH' ) {
675 die "unexpected format value of type " . ref ( $format ). " \n " ;
681 foreach my $part ( split ( /,/ , $data )) {
682 next if $part =~ /^\s*$/ ;
684 if ( $part =~ /^([^=]+)=(.+)$/ ) {
685 my ( $k, $v ) = ( $1, $2 );
686 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
687 my $schema = $format ->{ $k };
688 if ( my $alias = $schema ->{ alias
}) {
689 if ( my $key_alias = $schema ->{ keyAlias
}) {
690 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
691 $res ->{ $key_alias } = $k ;
694 $schema = $format ->{ $k };
697 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
698 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
699 $v = parse_boolean
( $v ) // $v ;
702 } elsif ( $part !~ /=/ ) {
703 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
704 foreach my $key ( keys %$format ) {
705 if ( $format ->{ $key }->{ default_key
}) {
707 if (! $res ->{ $default_key }) {
708 $res ->{ $default_key } = $part ;
711 die "duplicate key in comma-separated list property: $default_key\n " ;
714 die "value without key, but schema does not define a default key \n " if ! $default_key ;
716 die "missing key in comma-separated list property \n " ;
721 check_object
( $path, $format, $res, $additional_properties, $errors );
722 if ( scalar ( %$errors )) {
723 raise
"format error \n " , errors
=> $errors ;
730 my ( $errors, $path, $msg ) = @_ ;
732 $path = '_root' if ! $path ;
734 if ( $errors ->{ $path }) {
735 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
737 $errors ->{ $path } = $msg ;
744 # see 'man perlretut'
745 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
751 return $value =~ m/^[+-]?\d+$/ ;
755 my ( $path, $type, $value, $errors ) = @_ ;
759 if (! defined ( $value )) {
760 return 1 if $type eq 'null' ;
764 if ( my $tt = ref ( $type )) {
765 if ( $tt eq 'ARRAY' ) {
766 foreach my $t ( @$type ) {
768 check_type
( $path, $t, $value, $tmperr );
769 return 1 if ! scalar ( %$tmperr );
771 my $ttext = join ( '|' , @$type );
772 add_error
( $errors, $path, "type check (' $ttext ') failed" );
774 } elsif ( $tt eq 'HASH' ) {
776 check_prop
( $value, $type, $path, $tmperr );
777 return 1 if ! scalar ( %$tmperr );
778 add_error
( $errors, $path, "type check failed" );
781 die "internal error - got reference type ' $tt '" ;
786 return 1 if $type eq 'any' ;
788 if ( $type eq 'null' ) {
789 if ( defined ( $value )) {
790 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
796 my $vt = ref ( $value );
798 if ( $type eq 'array' ) {
799 if (! $vt || $vt ne 'ARRAY' ) {
800 add_error
( $errors, $path, "type check (' $type ') failed" );
804 } elsif ( $type eq 'object' ) {
805 if (! $vt || $vt ne 'HASH' ) {
806 add_error
( $errors, $path, "type check (' $type ') failed" );
810 } elsif ( $type eq 'coderef' ) {
811 if (! $vt || $vt ne 'CODE' ) {
812 add_error
( $errors, $path, "type check (' $type ') failed" );
816 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
817 # qr// regexes can be used as strings and make sense for format=regex
821 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
824 if ( $type eq 'string' ) {
825 return 1 ; # nothing to check ?
826 } elsif ( $type eq 'boolean' ) {
827 #if ($value =~ m/^(1|true|yes|on)$/i) {
830 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
831 } elsif ( $value eq '0' ) {
832 return 1 ; # return success (not value)
834 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
837 } elsif ( $type eq 'integer' ) {
838 if (! is_integer
( $value )) {
839 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
843 } elsif ( $type eq 'number' ) {
844 if (! is_number
( $value )) {
845 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
850 return 1 ; # no need to verify unknown types
860 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
862 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
864 my $st = ref ( $schema );
865 if (! $st || $st ne 'HASH' ) {
866 add_error
( $errors, $path, "Invalid schema definition." );
870 my $vt = ref ( $value );
871 if (! $vt || $vt ne 'HASH' ) {
872 add_error
( $errors, $path, "an object is required" );
876 foreach my $k ( keys %$schema ) {
877 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
880 foreach my $k ( keys %$value ) {
882 my $newpath = $path ?
" $path . $k " : $k ;
884 if ( my $subschema = $schema ->{ $k }) {
885 if ( my $requires = $subschema ->{ requires
}) {
886 if ( ref ( $requires )) {
887 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
888 check_prop
( $value, $requires, $path, $errors );
889 } elsif (! defined ( $value ->{ $requires })) {
890 add_error
( $errors, $path ?
" $path . $requires " : $requires,
891 "missing property - ' $newpath ' requires this property" );
895 next ; # value is already checked above
898 if ( defined ( $additional_properties ) && ! $additional_properties ) {
899 add_error
( $errors, $newpath, "property is not defined in schema " .
900 "and the schema does not allow additional properties" );
903 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
904 if ref ( $additional_properties );
908 sub check_object_warn
{
909 my ( $path, $schema, $value, $additional_properties ) = @_ ;
911 check_object
( $path, $schema, $value, $additional_properties, $errors );
912 if ( scalar ( %$errors )) {
913 foreach my $k ( keys %$errors ) {
914 warn "parse error: $k : $errors ->{ $k } \n " ;
922 my ( $value, $schema, $path, $errors ) = @_ ;
924 die "internal error - no schema" if ! $schema ;
925 die "internal error" if ! $errors ;
927 #print "check_prop $path\n" if $value;
929 my $st = ref ( $schema );
930 if (! $st || $st ne 'HASH' ) {
931 add_error
( $errors, $path, "Invalid schema definition." );
935 # if it extends another schema, it must pass that schema as well
936 if ( $schema ->{ extends
}) {
937 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
940 if (! defined ( $value )) {
941 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
942 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
943 add_error
( $errors, $path, "property is missing and it is not optional" );
948 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
950 if ( $schema ->{ disallow
}) {
952 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
953 add_error
( $errors, $path, "disallowed value was matched" );
958 if ( my $vt = ref ( $value )) {
960 if ( $vt eq 'ARRAY' ) {
961 if ( $schema ->{ items
}) {
962 my $it = ref ( $schema ->{ items
});
963 if ( $it && $it eq 'ARRAY' ) {
964 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
965 die "not implemented" ;
968 foreach my $el ( @$value ) {
969 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
975 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
976 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
977 $value, $schema ->{ additionalProperties
}, $errors );
983 if ( my $format = $schema ->{ format
}) {
984 eval { check_format
( $format, $value, $path ); };
986 add_error
( $errors, $path, "invalid format - $@ " );
991 if ( my $pattern = $schema ->{ pattern
}) {
992 if ( $value !~ m/^$pattern$/ ) {
993 add_error
( $errors, $path, "value does not match the regex pattern" );
998 if ( defined ( my $max = $schema ->{ maxLength
})) {
999 if ( length ( $value ) > $max ) {
1000 add_error
( $errors, $path, "value may only be $max characters long" );
1005 if ( defined ( my $min = $schema ->{ minLength
})) {
1006 if ( length ( $value ) < $min ) {
1007 add_error
( $errors, $path, "value must be at least $min characters long" );
1012 if ( is_number
( $value )) {
1013 if ( defined ( my $max = $schema ->{ maximum
})) {
1014 if ( $value > $max ) {
1015 add_error
( $errors, $path, "value must have a maximum value of $max " );
1020 if ( defined ( my $min = $schema ->{ minimum
})) {
1021 if ( $value < $min ) {
1022 add_error
( $errors, $path, "value must have a minimum value of $min " );
1028 if ( my $ea = $schema ->{ enum
}) {
1031 foreach my $ev ( @$ea ) {
1032 if ( $ev eq $value ) {
1038 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
1039 join ( ", " , @$ea ) . "'" );
1046 my ( $instance, $schema, $errmsg ) = @_ ;
1049 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1051 # todo: cycle detection is only needed for debugging, I guess
1052 # we can disable that in the final release
1053 # todo: is there a better/faster way to detect cycles?
1055 find_cycle
( $instance, sub { $cycles = 1 });
1057 add_error
( $errors, undef , "data structure contains recursive cycles" );
1059 check_prop
( $instance, $schema, '' , $errors );
1062 if ( scalar ( %$errors )) {
1063 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1069 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1070 my $default_schema_noref = {
1071 description
=> "This is the JSON Schema for JSON Schemas." ,
1072 type
=> [ "object" ],
1073 additionalProperties
=> 0 ,
1076 type
=> [ "string" , "array" ],
1077 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1082 enum
=> $schema_valid_types,
1084 enum
=> $schema_valid_types,
1088 description
=> "This indicates that the instance property in the instance object is not required." ,
1094 description
=> "This is a definition for the properties of an object value" ,
1100 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1104 additionalProperties
=> {
1105 type
=> [ "boolean" , "object" ],
1106 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1113 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1118 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1122 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1129 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1135 description
=> "A text representation of the type (used to generate documentation)." ,
1140 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." ,
1147 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1152 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)." ,
1154 verbose_description
=> {
1157 description
=> "This provides a more verbose description." ,
1159 format_description
=> {
1162 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1167 description
=> "This provides the title of the property" ,
1172 description
=> "This is used to provide rendering hints to format cli command output." ,
1175 type
=> [ "string" , "object" ],
1177 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1180 type
=> [ "string" , "object" ],
1182 description
=> "This indicates what format the data is among some predefined formats which may include: \n\n date - a string following the ISO format \n address \n schema - a schema definition object \n person \n page \n html - a string representing HTML" ,
1187 description
=> "Whether this is the default key in a comma separated list property string." ,
1192 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." ,
1197 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1198 requires
=> 'alias' ,
1203 description
=> "This indicates the default for the instance property."
1207 description
=> "Bash completion function. This function should return a list of possible values." ,
1213 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." ,
1218 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1221 # this is from hyper schema
1224 description
=> "This defines the link relations of the instance objects" ,
1231 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" ,
1235 description
=> "This is the name of the link relation" ,
1241 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1250 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1256 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1258 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1259 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1261 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1262 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1264 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1265 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1267 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1268 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1270 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1271 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1273 my $method_schema = {
1275 additionalProperties
=> 0 ,
1278 description
=> "This a description of the method" ,
1283 description
=> "This indicates the name of the function to call." ,
1286 additionalProperties
=> 1 ,
1301 description
=> "The HTTP method name." ,
1302 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1307 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1312 description
=> "Method is available for clients authenticated using an API token." ,
1318 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1323 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1326 proxyto_callback
=> {
1328 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1333 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1335 additionalProperties
=> 0 ,
1338 description
=> "Describe access permissions." ,
1342 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1344 enum
=> [ 'all' , 'world' ],
1348 description
=> "Array of permission checks (prefix notation)." ,
1355 description
=> "Used internally" ,
1359 description
=> "Used internally" ,
1364 description
=> "path for URL matching (uri template)" ,
1366 fragmentDelimiter
=> {
1368 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." ,
1373 description
=> "JSON Schema for parameters." ,
1378 description
=> "JSON Schema for return value." ,
1383 description
=> "method implementation (code reference)" ,
1388 description
=> "Delegate call to this class (perl class string)." ,
1391 additionalProperties
=> 0 ,
1397 fragmentDelimiter
=> { optional
=> 1 }
1405 sub validate_schema
{
1408 my $errmsg = "internal error - unable to verify schema \n " ;
1409 validate
( $schema, $default_schema, $errmsg );
1412 sub validate_method_info
{
1415 my $errmsg = "internal error - unable to verify method info \n " ;
1416 validate
( $info, $method_schema, $errmsg );
1418 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1419 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1422 # run a self test on load
1423 # make sure we can verify the default schema
1424 validate_schema
( $default_schema_noref );
1425 validate_schema
( $method_schema );
1427 # and now some utility methods (used by pve api)
1428 sub method_get_child_link
{
1431 return undef if ! $info ;
1433 my $schema = $info ->{ returns
};
1434 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1436 my $links = $schema ->{ links
};
1437 return undef if ! $links ;
1440 foreach my $lnk ( @$links ) {
1441 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1450 # a way to parse command line parameters, using a
1451 # schema to configure Getopt::Long
1453 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1455 if (! $schema || ! $schema ->{ properties
}) {
1456 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1457 if scalar ( @$args ) != 0 ;
1462 if ( $arg_param && ! ref ( $arg_param )) {
1463 my $pd = $schema ->{ properties
}->{ $arg_param };
1464 die "expected list format $pd ->{format}"
1465 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1466 $list_param = $arg_param ;
1469 my @interactive = ();
1471 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1472 my $pd = $schema ->{ properties
}->{ $prop };
1473 next if $list_param && $prop eq $list_param ;
1474 next if defined ( $fixed_param ->{ $prop });
1476 my $mapping = $param_mapping_hash ->{ $prop };
1477 if ( $mapping && $mapping ->{ interactive
}) {
1478 # interactive parameters such as passwords: make the argument
1479 # optional and call the mapping function afterwards.
1480 push @getopt, " $prop :s" ;
1481 push @interactive, [ $prop, $mapping ->{ func
}];
1482 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1483 push @getopt, " $prop :s" ;
1485 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1486 push @getopt, " $prop =s@" ;
1488 push @getopt, " $prop =s" ;
1493 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1496 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1497 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1501 $opts ->{ $list_param } = $args ;
1503 } elsif ( ref ( $arg_param )) {
1504 foreach my $arg_name ( @$arg_param ) {
1505 if ( $opts ->{ 'extra-args' }) {
1506 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1508 if ( $arg_name eq 'extra-args' ) {
1509 $opts ->{ 'extra-args' } = $args ;
1513 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1514 $opts ->{ $arg_name } = shift @$args ;
1516 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1518 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1519 if scalar ( @$args ) != 0 ;
1522 if ( ref ( $arg_param )) {
1523 foreach my $arg_name ( @$arg_param ) {
1524 if ( $arg_name eq 'extra-args' ) {
1525 $opts ->{ 'extra-args' } = [];
1527 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1533 foreach my $entry ( @interactive ) {
1534 my ( $opt, $func ) = @$entry ;
1535 my $pd = $schema ->{ properties
}->{ $opt };
1536 my $value = $opts ->{ $opt };
1537 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1538 $opts ->{ $opt } = $func ->( $value );
1542 # decode after Getopt as we are not sure how well it handles unicode
1543 foreach my $p ( keys %$opts ) {
1544 if (! ref ( $opts ->{ $p })) {
1545 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1546 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1548 foreach my $v (@{ $opts ->{ $p }}) {
1549 push @$tmp, decode
( 'locale' , $v );
1552 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1553 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1555 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1559 foreach my $p ( keys %$opts ) {
1560 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1561 if ( $pd ->{ type
} eq 'boolean' ) {
1562 if ( $opts ->{ $p } eq '' ) {
1564 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1565 $opts ->{ $p } = $bool ;
1567 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1569 } elsif ( $pd ->{ format
}) {
1571 if ( $pd ->{ format
} =~ m/-list/ ) {
1572 # allow --vmid 100 --vmid 101 and --vmid 100,101
1573 # allow --dow mon --dow fri and --dow mon,fri
1574 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1575 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1576 # we encode array as \0 separated strings
1577 # Note: CGI.pm also use this encoding
1578 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1579 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1581 # st that split_list knows it is \0 terminated
1582 my $v = $opts ->{ $p }->[ 0 ];
1583 $opts ->{ $p } = " $v\0 " ;
1590 foreach my $p ( keys %$fixed_param ) {
1591 $opts ->{ $p } = $fixed_param ->{ $p };
1597 # A way to parse configuration data by giving a json schema
1599 my ( $schema, $filename, $raw ) = @_ ;
1601 # do fast check (avoid validate_schema($schema))
1602 die "got strange schema" if ! $schema ->{ type
} ||
1603 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1607 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1610 next if $line =~ /^#/ ;
1612 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1615 if ( $schema ->{ properties
}->{ $key } &&
1616 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1618 $value = parse_boolean
( $value ) // $value ;
1620 $cfg ->{ $key } = $value ;
1622 warn "ignore config line: $line\n "
1627 check_prop
( $cfg, $schema, '' , $errors );
1629 foreach my $k ( keys %$errors ) {
1630 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1637 # generate simple key/value file
1639 my ( $schema, $filename, $cfg ) = @_ ;
1641 # do fast check (avoid validate_schema($schema))
1642 die "got strange schema" if ! $schema ->{ type
} ||
1643 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1645 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1649 foreach my $k ( sort keys %$cfg ) {
1650 $data .= " $k : $cfg ->{ $k } \n " ;
1656 # helpers used to generate our manual pages
1658 my $find_schema_default_key = sub {
1662 my $keyAliasProps = {};
1664 foreach my $key ( keys %$format ) {
1665 my $phash = $format ->{ $key };
1666 if ( $phash ->{ default_key
}) {
1667 die "multiple default keys in schema ( $default_key, $key ) \n "
1668 if defined ( $default_key );
1669 die "default key ' $key ' is an alias - this is not allowed \n "
1670 if defined ( $phash ->{ alias
});
1671 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1672 if $phash ->{ keyAlias
};
1673 $default_key = $key ;
1675 my $key_alias = $phash ->{ keyAlias
};
1676 die "found keyAlias without 'alias definition for ' $key ' \n "
1677 if $key_alias && ! $phash ->{ alias
};
1679 if ( $phash ->{ alias
} && $key_alias ) {
1680 die "inconsistent keyAlias ' $key_alias ' definition"
1681 if defined ( $keyAliasProps ->{ $key_alias }) &&
1682 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1683 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1687 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1690 sub generate_typetext
{
1691 my ( $format, $list_enums ) = @_ ;
1693 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1698 my $add_option_string = sub {
1699 my ( $text, $optional ) = @_ ;
1705 $text = "[ $text ]" if $optional ;
1710 my $format_key_value = sub {
1711 my ( $key, $phash ) = @_ ;
1713 die "internal error" if defined ( $phash ->{ alias
});
1719 if ( my $desc = $phash ->{ format_description
}) {
1720 $typetext .= "< $desc >" ;
1721 } elsif ( my $text = $phash ->{ typetext
}) {
1723 } elsif ( my $enum = $phash ->{ enum
}) {
1724 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1725 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1727 $typetext .= '<enum>' ;
1729 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1730 $typetext .= '<1|0>' ;
1731 } elsif ( $phash ->{ type
} eq 'integer' ) {
1732 $typetext .= '<integer>' ;
1733 } elsif ( $phash ->{ type
} eq 'number' ) {
1734 $typetext .= '<number>' ;
1736 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1739 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1740 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1742 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1748 my $cond_add_key = sub {
1751 return if $done ->{ $key }; # avoid duplicates
1755 my $phash = $format ->{ $key };
1757 return if ! $phash ; # should not happen
1759 return if $phash ->{ alias
};
1761 & $format_key_value ( $key, $phash );
1765 & $cond_add_key ( $default_key ) if defined ( $default_key );
1767 # add required keys first
1768 foreach my $key ( sort keys %$format ) {
1769 my $phash = $format ->{ $key };
1770 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1774 foreach my $key ( sort keys %$format ) {
1775 & $cond_add_key ( $key );
1778 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1779 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1785 sub print_property_string
{
1786 my ( $data, $format, $skip, $path ) = @_ ;
1788 if ( ref ( $format ) ne 'HASH' ) {
1789 my $schema = get_format
( $format );
1790 die "not a valid format: $format\n " if ! $schema ;
1795 check_object
( $path, $format, $data, undef , $errors );
1796 if ( scalar ( %$errors )) {
1797 raise
"format error" , errors
=> $errors ;
1800 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1805 my $add_option_string = sub {
1808 $res .= ',' if $add_sep ;
1813 my $format_value = sub {
1814 my ( $key, $value, $format ) = @_ ;
1816 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1817 return format_size
( $value );
1819 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1824 my $done = { map { $_ => 1 } @$skip };
1826 my $cond_add_key = sub {
1827 my ( $key, $isdefault ) = @_ ;
1829 return if $done ->{ $key }; # avoid duplicates
1833 my $value = $data ->{ $key };
1835 return if ! defined ( $value );
1837 my $phash = $format ->{ $key };
1839 # try to combine values if we have key aliases
1840 if ( my $combine = $keyAliasProps ->{ $key }) {
1841 if ( defined ( my $combine_value = $data ->{ $combine })) {
1842 my $combine_format = $format ->{ $combine }->{ format
};
1843 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1844 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1845 & $add_option_string ( "${value_str}=${combine_str}" );
1846 $done ->{ $combine } = 1 ;
1851 if ( $phash && $phash ->{ alias
}) {
1852 $phash = $format ->{ $phash ->{ alias
}};
1855 die "invalid key ' $key ' \n " if ! $phash ;
1856 die "internal error" if defined ( $phash ->{ alias
});
1858 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1860 & $add_option_string ( $value_str );
1862 & $add_option_string ( " $key =${value_str}" );
1866 # add default key first
1867 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1869 # add required keys first
1870 foreach my $key ( sort keys %$data ) {
1871 my $phash = $format ->{ $key };
1872 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1876 foreach my $key ( sort keys %$data ) {
1877 & $cond_add_key ( $key );
1883 sub schema_get_type_text
{
1884 my ( $phash, $style ) = @_ ;
1886 my $type = $phash ->{ type
} || 'string' ;
1888 if ( $phash ->{ typetext
}) {
1889 return $phash ->{ typetext
};
1890 } elsif ( $phash ->{ format_description
}) {
1891 return "< $phash ->{format_description}>" ;
1892 } elsif ( $phash ->{ enum
}) {
1893 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
1894 } elsif ( $phash ->{ pattern
}) {
1895 return $phash ->{ pattern
};
1896 } elsif ( $type eq 'integer' || $type eq 'number' ) {
1897 # NOTE: always access values as number (avoid converion to string)
1898 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
1899 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
1900 ( $phash ->{ maximum
} + 0 ) . ")" ;
1901 } elsif ( defined ( $phash ->{ minimum
})) {
1902 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
1903 } elsif ( defined ( $phash ->{ maximum
})) {
1904 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
1906 } elsif ( $type eq 'string' ) {
1907 if ( my $format = $phash ->{ format
}) {
1908 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
1909 if ( ref ( $format ) eq 'HASH' ) {
1911 $list_enums = 1 if $style && $style eq 'config-sub' ;
1912 return generate_typetext
( $format, $list_enums );