]>
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 my $ipv4_mask_hash = {
286 '255.255.128.0' => 17 ,
287 '255.255.192.0' => 18 ,
288 '255.255.224.0' => 19 ,
289 '255.255.240.0' => 20 ,
290 '255.255.248.0' => 21 ,
291 '255.255.252.0' => 22 ,
292 '255.255.254.0' => 23 ,
293 '255.255.255.0' => 24 ,
294 '255.255.255.128' => 25 ,
295 '255.255.255.192' => 26 ,
296 '255.255.255.224' => 27 ,
297 '255.255.255.240' => 28 ,
298 '255.255.255.248' => 29 ,
299 '255.255.255.252' => 30 ,
300 '255.255.255.254' => 31 ,
301 '255.255.255.255' => 32 ,
304 sub get_netmask_bits
{
306 return $ipv4_mask_hash ->{ $mask };
309 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
310 sub pve_verify_ipv4mask
{
311 my ( $mask, $noerr ) = @_ ;
313 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
314 return undef if $noerr ;
315 die "value does not look like a valid IP netmask \n " ;
320 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
321 sub pve_verify_cidrv6
{
322 my ( $cidr, $noerr ) = @_ ;
324 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
328 return undef if $noerr ;
329 die "value does not look like a valid IPv6 CIDR network \n " ;
332 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
333 sub pve_verify_cidrv4
{
334 my ( $cidr, $noerr ) = @_ ;
336 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
340 return undef if $noerr ;
341 die "value does not look like a valid IPv4 CIDR network \n " ;
344 register_format
( 'CIDR' , \
& pve_verify_cidr
);
345 sub pve_verify_cidr
{
346 my ( $cidr, $noerr ) = @_ ;
348 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
349 pve_verify_cidrv6
( $cidr, 1 )))
351 return undef if $noerr ;
352 die "value does not look like a valid CIDR network \n " ;
358 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
359 sub pve_verify_ipv4_config
{
360 my ( $config, $noerr ) = @_ ;
362 return $config if $config =~ /^(?:dhcp|manual)$/ ||
363 pve_verify_cidrv4
( $config, 1 );
364 return undef if $noerr ;
365 die "value does not look like a valid ipv4 network configuration \n " ;
368 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
369 sub pve_verify_ipv6_config
{
370 my ( $config, $noerr ) = @_ ;
372 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
373 pve_verify_cidrv6
( $config, 1 );
374 return undef if $noerr ;
375 die "value does not look like a valid ipv6 network configuration \n " ;
378 register_format
( 'email' , \
& pve_verify_email
);
379 sub pve_verify_email
{
380 my ( $email, $noerr ) = @_ ;
382 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
383 return undef if $noerr ;
384 die "value does not look like a valid email address \n " ;
389 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
390 sub pve_verify_dns_name
{
391 my ( $name, $noerr ) = @_ ;
393 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
395 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
396 return undef if $noerr ;
397 die "value does not look like a valid DNS name \n " ;
402 # network interface name
403 register_format
( 'pve-iface' , \
& pve_verify_iface
);
404 sub pve_verify_iface
{
405 my ( $id, $noerr ) = @_ ;
407 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
408 return undef if $noerr ;
409 die "invalid network interface name ' $id ' \n " ;
414 # general addresses by name or IP
415 register_format
( 'address' , \
& pve_verify_address
);
416 sub pve_verify_address
{
417 my ( $addr, $noerr ) = @_ ;
419 if (!( pve_verify_ip
( $addr, 1 ) ||
420 pve_verify_dns_name
( $addr, 1 )))
422 return undef if $noerr ;
423 die "value does not look like a valid address: $addr\n " ;
428 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
429 sub pve_verify_disk_size
{
430 my ( $size, $noerr ) = @_ ;
431 if (! defined ( parse_size
( $size ))) {
432 return undef if $noerr ;
433 die "value does not look like a valid disk size: $size\n " ;
438 register_standard_option
( 'spice-proxy' , {
439 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)." ,
440 type
=> 'string' , format
=> 'address' ,
443 register_standard_option
( 'remote-viewer-config' , {
444 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
445 additionalProperties
=> 1 ,
447 type
=> { type
=> 'string' },
448 password
=> { type
=> 'string' },
449 proxy
=> { type
=> 'string' },
450 host
=> { type
=> 'string' },
451 'tls-port' => { type
=> 'integer' },
455 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
456 sub pve_verify_startup_order
{
457 my ( $value, $noerr ) = @_ ;
459 return $value if pve_parse_startup_order
( $value );
461 return undef if $noerr ;
463 die "unable to parse startup options \n " ;
468 type
=> 'number' , minimum
=> '0' ,
469 format_description
=> 'LIMIT' ,
472 my $bwlimit_format = {
475 description
=> 'default bandwidth limit in KiB/s' ,
479 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
483 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
487 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
491 description
=> 'bandwidth limit in KiB/s for moving disks' ,
494 register_format
( 'bwlimit' , $bwlimit_format );
495 register_standard_option
( 'bwlimit' , {
496 description
=> "Set bandwidth/io limits various operations." ,
499 format
=> $bwlimit_format,
502 # used for pve-tag-list in e.g., guest configs
503 register_format
( 'pve-tag' , \
& pve_verify_tag
);
505 my ( $value, $noerr ) = @_ ;
507 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i ;
509 return undef if $noerr ;
511 die "invalid characters in tag \n " ;
514 sub pve_parse_startup_order
{
517 return undef if ! $value ;
521 foreach my $p ( split ( /,/ , $value )) {
522 next if $p =~ m/^\s*$/ ;
524 if ( $p =~ m/^(order=)?(\d+)$/ ) {
526 } elsif ( $p =~ m/^up=(\d+)$/ ) {
528 } elsif ( $p =~ m/^down=(\d+)$/ ) {
538 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
539 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." ,
541 type
=> 'string' , format
=> 'pve-startup-order' ,
542 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
545 register_format
( 'pve-tfa-secret' , \
& pve_verify_tfa_secret
);
546 sub pve_verify_tfa_secret
{
547 my ( $key, $noerr ) = @_ ;
549 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
550 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
551 # format to support arbitrary lengths properly:
552 if ( $key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
553 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
554 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/ ) # and the old pattern copy&pasted
559 return undef if $noerr ;
561 die "unable to decode TFA secret \n " ;
565 my ( $format, $value, $path ) = @_ ;
567 return parse_property_string
( $format, $value, $path ) if ref ( $format ) eq 'HASH' ;
568 return if $format eq 'regex' ;
570 if ( $format =~ m/^(.*)-a?list$/ ) {
572 my $code = $format_list ->{ $1 };
574 die "undefined format ' $format ' \n " if ! $code ;
576 # Note: we allow empty lists
577 foreach my $v ( split_list
( $value )) {
581 } elsif ( $format =~ m/^(.*)-opt$/ ) {
583 my $code = $format_list ->{ $1 };
585 die "undefined format ' $format ' \n " if ! $code ;
587 return if ! $value ; # allow empty string
593 my $code = $format_list ->{ $format };
595 die "undefined format ' $format ' \n " if ! $code ;
597 return parse_property_string
( $code, $value, $path ) if ref ( $code ) eq 'HASH' ;
605 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
606 my ( $size, $unit ) = ( $1, $3 );
609 $size = $size * 1024 ;
610 } elsif ( $unit eq 'M' ) {
611 $size = $size * 1024 * 1024 ;
612 } elsif ( $unit eq 'G' ) {
613 $size = $size * 1024 * 1024 * 1024 ;
614 } elsif ( $unit eq 'T' ) {
615 $size = $size * 1024 * 1024 * 1024 * 1024 ;
626 my $kb = int ( $size/1024 );
627 return $size if $kb*1024 != $size ;
629 my $mb = int ( $kb/1024 );
630 return "${kb}K" if $mb*1024 != $kb ;
632 my $gb = int ( $mb/1024 );
633 return "${mb}M" if $gb*1024 != $mb ;
635 my $tb = int ( $gb/1024 );
636 return "${gb}G" if $tb*1024 != $gb ;
643 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
644 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
648 sub parse_property_string
{
649 my ( $format, $data, $path, $additional_properties ) = @_ ;
651 # In property strings we default to not allowing additional properties
652 $additional_properties = 0 if ! defined ( $additional_properties );
654 # Support named formats here, too:
656 if ( my $desc = $format_list ->{ $format }) {
659 die "unknown format: $format\n " ;
661 } elsif ( ref ( $format ) ne 'HASH' ) {
662 die "unexpected format value of type " . ref ( $format ). " \n " ;
668 foreach my $part ( split ( /,/ , $data )) {
669 next if $part =~ /^\s*$/ ;
671 if ( $part =~ /^([^=]+)=(.+)$/ ) {
672 my ( $k, $v ) = ( $1, $2 );
673 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
674 my $schema = $format ->{ $k };
675 if ( my $alias = $schema ->{ alias
}) {
676 if ( my $key_alias = $schema ->{ keyAlias
}) {
677 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
678 $res ->{ $key_alias } = $k ;
681 $schema = $format ->{ $k };
684 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
685 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
686 $v = parse_boolean
( $v ) // $v ;
689 } elsif ( $part !~ /=/ ) {
690 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
691 foreach my $key ( keys %$format ) {
692 if ( $format ->{ $key }->{ default_key
}) {
694 if (! $res ->{ $default_key }) {
695 $res ->{ $default_key } = $part ;
698 die "duplicate key in comma-separated list property: $default_key\n " ;
701 die "value without key, but schema does not define a default key \n " if ! $default_key ;
703 die "missing key in comma-separated list property \n " ;
708 check_object
( $path, $format, $res, $additional_properties, $errors );
709 if ( scalar ( %$errors )) {
710 raise
"format error \n " , errors
=> $errors ;
717 my ( $errors, $path, $msg ) = @_ ;
719 $path = '_root' if ! $path ;
721 if ( $errors ->{ $path }) {
722 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
724 $errors ->{ $path } = $msg ;
731 # see 'man perlretut'
732 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
738 return $value =~ m/^[+-]?\d+$/ ;
742 my ( $path, $type, $value, $errors ) = @_ ;
746 if (! defined ( $value )) {
747 return 1 if $type eq 'null' ;
751 if ( my $tt = ref ( $type )) {
752 if ( $tt eq 'ARRAY' ) {
753 foreach my $t ( @$type ) {
755 check_type
( $path, $t, $value, $tmperr );
756 return 1 if ! scalar ( %$tmperr );
758 my $ttext = join ( '|' , @$type );
759 add_error
( $errors, $path, "type check (' $ttext ') failed" );
761 } elsif ( $tt eq 'HASH' ) {
763 check_prop
( $value, $type, $path, $tmperr );
764 return 1 if ! scalar ( %$tmperr );
765 add_error
( $errors, $path, "type check failed" );
768 die "internal error - got reference type ' $tt '" ;
773 return 1 if $type eq 'any' ;
775 if ( $type eq 'null' ) {
776 if ( defined ( $value )) {
777 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
783 my $vt = ref ( $value );
785 if ( $type eq 'array' ) {
786 if (! $vt || $vt ne 'ARRAY' ) {
787 add_error
( $errors, $path, "type check (' $type ') failed" );
791 } elsif ( $type eq 'object' ) {
792 if (! $vt || $vt ne 'HASH' ) {
793 add_error
( $errors, $path, "type check (' $type ') failed" );
797 } elsif ( $type eq 'coderef' ) {
798 if (! $vt || $vt ne 'CODE' ) {
799 add_error
( $errors, $path, "type check (' $type ') failed" );
803 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
804 # qr// regexes can be used as strings and make sense for format=regex
808 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
811 if ( $type eq 'string' ) {
812 return 1 ; # nothing to check ?
813 } elsif ( $type eq 'boolean' ) {
814 #if ($value =~ m/^(1|true|yes|on)$/i) {
817 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
818 } elsif ( $value eq '0' ) {
819 return 1 ; # return success (not value)
821 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
824 } elsif ( $type eq 'integer' ) {
825 if (! is_integer
( $value )) {
826 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
830 } elsif ( $type eq 'number' ) {
831 if (! is_number
( $value )) {
832 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
837 return 1 ; # no need to verify unknown types
847 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
849 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
851 my $st = ref ( $schema );
852 if (! $st || $st ne 'HASH' ) {
853 add_error
( $errors, $path, "Invalid schema definition." );
857 my $vt = ref ( $value );
858 if (! $vt || $vt ne 'HASH' ) {
859 add_error
( $errors, $path, "an object is required" );
863 foreach my $k ( keys %$schema ) {
864 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
867 foreach my $k ( keys %$value ) {
869 my $newpath = $path ?
" $path . $k " : $k ;
871 if ( my $subschema = $schema ->{ $k }) {
872 if ( my $requires = $subschema ->{ requires
}) {
873 if ( ref ( $requires )) {
874 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
875 check_prop
( $value, $requires, $path, $errors );
876 } elsif (! defined ( $value ->{ $requires })) {
877 add_error
( $errors, $path ?
" $path . $requires " : $requires,
878 "missing property - ' $newpath ' requires this property" );
882 next ; # value is already checked above
885 if ( defined ( $additional_properties ) && ! $additional_properties ) {
886 add_error
( $errors, $newpath, "property is not defined in schema " .
887 "and the schema does not allow additional properties" );
890 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
891 if ref ( $additional_properties );
895 sub check_object_warn
{
896 my ( $path, $schema, $value, $additional_properties ) = @_ ;
898 check_object
( $path, $schema, $value, $additional_properties, $errors );
899 if ( scalar ( %$errors )) {
900 foreach my $k ( keys %$errors ) {
901 warn "parse error: $k : $errors ->{ $k } \n " ;
909 my ( $value, $schema, $path, $errors ) = @_ ;
911 die "internal error - no schema" if ! $schema ;
912 die "internal error" if ! $errors ;
914 #print "check_prop $path\n" if $value;
916 my $st = ref ( $schema );
917 if (! $st || $st ne 'HASH' ) {
918 add_error
( $errors, $path, "Invalid schema definition." );
922 # if it extends another schema, it must pass that schema as well
923 if ( $schema ->{ extends
}) {
924 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
927 if (! defined ( $value )) {
928 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
929 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
930 add_error
( $errors, $path, "property is missing and it is not optional" );
935 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
937 if ( $schema ->{ disallow
}) {
939 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
940 add_error
( $errors, $path, "disallowed value was matched" );
945 if ( my $vt = ref ( $value )) {
947 if ( $vt eq 'ARRAY' ) {
948 if ( $schema ->{ items
}) {
949 my $it = ref ( $schema ->{ items
});
950 if ( $it && $it eq 'ARRAY' ) {
951 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
952 die "not implemented" ;
955 foreach my $el ( @$value ) {
956 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
962 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
963 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
964 $value, $schema ->{ additionalProperties
}, $errors );
970 if ( my $format = $schema ->{ format
}) {
971 eval { check_format
( $format, $value, $path ); };
973 add_error
( $errors, $path, "invalid format - $@ " );
978 if ( my $pattern = $schema ->{ pattern
}) {
979 if ( $value !~ m/^$pattern$/ ) {
980 add_error
( $errors, $path, "value does not match the regex pattern" );
985 if ( defined ( my $max = $schema ->{ maxLength
})) {
986 if ( length ( $value ) > $max ) {
987 add_error
( $errors, $path, "value may only be $max characters long" );
992 if ( defined ( my $min = $schema ->{ minLength
})) {
993 if ( length ( $value ) < $min ) {
994 add_error
( $errors, $path, "value must be at least $min characters long" );
999 if ( is_number
( $value )) {
1000 if ( defined ( my $max = $schema ->{ maximum
})) {
1001 if ( $value > $max ) {
1002 add_error
( $errors, $path, "value must have a maximum value of $max " );
1007 if ( defined ( my $min = $schema ->{ minimum
})) {
1008 if ( $value < $min ) {
1009 add_error
( $errors, $path, "value must have a minimum value of $min " );
1015 if ( my $ea = $schema ->{ enum
}) {
1018 foreach my $ev ( @$ea ) {
1019 if ( $ev eq $value ) {
1025 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
1026 join ( ", " , @$ea ) . "'" );
1033 my ( $instance, $schema, $errmsg ) = @_ ;
1036 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1038 # todo: cycle detection is only needed for debugging, I guess
1039 # we can disable that in the final release
1040 # todo: is there a better/faster way to detect cycles?
1042 find_cycle
( $instance, sub { $cycles = 1 });
1044 add_error
( $errors, undef , "data structure contains recursive cycles" );
1046 check_prop
( $instance, $schema, '' , $errors );
1049 if ( scalar ( %$errors )) {
1050 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1056 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1057 my $default_schema_noref = {
1058 description
=> "This is the JSON Schema for JSON Schemas." ,
1059 type
=> [ "object" ],
1060 additionalProperties
=> 0 ,
1063 type
=> [ "string" , "array" ],
1064 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1069 enum
=> $schema_valid_types,
1071 enum
=> $schema_valid_types,
1075 description
=> "This indicates that the instance property in the instance object is not required." ,
1081 description
=> "This is a definition for the properties of an object value" ,
1087 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1091 additionalProperties
=> {
1092 type
=> [ "boolean" , "object" ],
1093 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1100 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1105 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1109 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1116 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1122 description
=> "A text representation of the type (used to generate documentation)." ,
1127 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." ,
1134 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1139 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)." ,
1141 verbose_description
=> {
1144 description
=> "This provides a more verbose description." ,
1146 format_description
=> {
1149 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1154 description
=> "This provides the title of the property" ,
1159 description
=> "This is used to provide rendering hints to format cli command output." ,
1162 type
=> [ "string" , "object" ],
1164 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1167 type
=> [ "string" , "object" ],
1169 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" ,
1174 description
=> "Whether this is the default key in a comma separated list property string." ,
1179 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." ,
1184 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1185 requires
=> 'alias' ,
1190 description
=> "This indicates the default for the instance property."
1194 description
=> "Bash completion function. This function should return a list of possible values." ,
1200 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." ,
1205 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1208 # this is from hyper schema
1211 description
=> "This defines the link relations of the instance objects" ,
1218 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" ,
1222 description
=> "This is the name of the link relation" ,
1228 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1237 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1243 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1245 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1246 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1248 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1249 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1251 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1252 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1254 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1255 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1257 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1258 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1260 my $method_schema = {
1262 additionalProperties
=> 0 ,
1265 description
=> "This a description of the method" ,
1270 description
=> "This indicates the name of the function to call." ,
1273 additionalProperties
=> 1 ,
1288 description
=> "The HTTP method name." ,
1289 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1294 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1299 description
=> "Method is available for clients authenticated using an API token." ,
1305 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1310 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1313 proxyto_callback
=> {
1315 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1320 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1322 additionalProperties
=> 0 ,
1325 description
=> "Describe access permissions." ,
1329 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1331 enum
=> [ 'all' , 'world' ],
1335 description
=> "Array of permission checks (prefix notation)." ,
1342 description
=> "Used internally" ,
1346 description
=> "Used internally" ,
1351 description
=> "path for URL matching (uri template)" ,
1353 fragmentDelimiter
=> {
1355 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." ,
1360 description
=> "JSON Schema for parameters." ,
1365 description
=> "JSON Schema for return value." ,
1370 description
=> "method implementation (code reference)" ,
1375 description
=> "Delegate call to this class (perl class string)." ,
1378 additionalProperties
=> 0 ,
1384 fragmentDelimiter
=> { optional
=> 1 }
1392 sub validate_schema
{
1395 my $errmsg = "internal error - unable to verify schema \n " ;
1396 validate
( $schema, $default_schema, $errmsg );
1399 sub validate_method_info
{
1402 my $errmsg = "internal error - unable to verify method info \n " ;
1403 validate
( $info, $method_schema, $errmsg );
1405 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1406 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1409 # run a self test on load
1410 # make sure we can verify the default schema
1411 validate_schema
( $default_schema_noref );
1412 validate_schema
( $method_schema );
1414 # and now some utility methods (used by pve api)
1415 sub method_get_child_link
{
1418 return undef if ! $info ;
1420 my $schema = $info ->{ returns
};
1421 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1423 my $links = $schema ->{ links
};
1424 return undef if ! $links ;
1427 foreach my $lnk ( @$links ) {
1428 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1437 # a way to parse command line parameters, using a
1438 # schema to configure Getopt::Long
1440 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1442 if (! $schema || ! $schema ->{ properties
}) {
1443 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1444 if scalar ( @$args ) != 0 ;
1449 if ( $arg_param && ! ref ( $arg_param )) {
1450 my $pd = $schema ->{ properties
}->{ $arg_param };
1451 die "expected list format $pd ->{format}"
1452 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1453 $list_param = $arg_param ;
1456 my @interactive = ();
1458 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1459 my $pd = $schema ->{ properties
}->{ $prop };
1460 next if $list_param && $prop eq $list_param ;
1461 next if defined ( $fixed_param ->{ $prop });
1463 my $mapping = $param_mapping_hash ->{ $prop };
1464 if ( $mapping && $mapping ->{ interactive
}) {
1465 # interactive parameters such as passwords: make the argument
1466 # optional and call the mapping function afterwards.
1467 push @getopt, " $prop :s" ;
1468 push @interactive, [ $prop, $mapping ->{ func
}];
1469 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1470 push @getopt, " $prop :s" ;
1472 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1473 push @getopt, " $prop =s@" ;
1475 push @getopt, " $prop =s" ;
1480 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1483 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1484 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1488 $opts ->{ $list_param } = $args ;
1490 } elsif ( ref ( $arg_param )) {
1491 foreach my $arg_name ( @$arg_param ) {
1492 if ( $opts ->{ 'extra-args' }) {
1493 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1495 if ( $arg_name eq 'extra-args' ) {
1496 $opts ->{ 'extra-args' } = $args ;
1500 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1501 $opts ->{ $arg_name } = shift @$args ;
1503 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1505 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1506 if scalar ( @$args ) != 0 ;
1509 if ( ref ( $arg_param )) {
1510 foreach my $arg_name ( @$arg_param ) {
1511 if ( $arg_name eq 'extra-args' ) {
1512 $opts ->{ 'extra-args' } = [];
1514 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1520 foreach my $entry ( @interactive ) {
1521 my ( $opt, $func ) = @$entry ;
1522 my $pd = $schema ->{ properties
}->{ $opt };
1523 my $value = $opts ->{ $opt };
1524 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1525 $opts ->{ $opt } = $func ->( $value );
1529 # decode after Getopt as we are not sure how well it handles unicode
1530 foreach my $p ( keys %$opts ) {
1531 if (! ref ( $opts ->{ $p })) {
1532 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1533 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1535 foreach my $v (@{ $opts ->{ $p }}) {
1536 push @$tmp, decode
( 'locale' , $v );
1539 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1540 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1542 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1546 foreach my $p ( keys %$opts ) {
1547 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1548 if ( $pd ->{ type
} eq 'boolean' ) {
1549 if ( $opts ->{ $p } eq '' ) {
1551 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1552 $opts ->{ $p } = $bool ;
1554 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1556 } elsif ( $pd ->{ format
}) {
1558 if ( $pd ->{ format
} =~ m/-list/ ) {
1559 # allow --vmid 100 --vmid 101 and --vmid 100,101
1560 # allow --dow mon --dow fri and --dow mon,fri
1561 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1562 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1563 # we encode array as \0 separated strings
1564 # Note: CGI.pm also use this encoding
1565 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1566 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1568 # st that split_list knows it is \0 terminated
1569 my $v = $opts ->{ $p }->[ 0 ];
1570 $opts ->{ $p } = " $v\0 " ;
1577 foreach my $p ( keys %$fixed_param ) {
1578 $opts ->{ $p } = $fixed_param ->{ $p };
1584 # A way to parse configuration data by giving a json schema
1586 my ( $schema, $filename, $raw ) = @_ ;
1588 # do fast check (avoid validate_schema($schema))
1589 die "got strange schema" if ! $schema ->{ type
} ||
1590 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1594 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1597 next if $line =~ /^#/ ;
1599 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1602 if ( $schema ->{ properties
}->{ $key } &&
1603 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1605 $value = parse_boolean
( $value ) // $value ;
1607 $cfg ->{ $key } = $value ;
1609 warn "ignore config line: $line\n "
1614 check_prop
( $cfg, $schema, '' , $errors );
1616 foreach my $k ( keys %$errors ) {
1617 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1624 # generate simple key/value file
1626 my ( $schema, $filename, $cfg ) = @_ ;
1628 # do fast check (avoid validate_schema($schema))
1629 die "got strange schema" if ! $schema ->{ type
} ||
1630 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1632 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1636 foreach my $k ( sort keys %$cfg ) {
1637 $data .= " $k : $cfg ->{ $k } \n " ;
1643 # helpers used to generate our manual pages
1645 my $find_schema_default_key = sub {
1649 my $keyAliasProps = {};
1651 foreach my $key ( keys %$format ) {
1652 my $phash = $format ->{ $key };
1653 if ( $phash ->{ default_key
}) {
1654 die "multiple default keys in schema ( $default_key, $key ) \n "
1655 if defined ( $default_key );
1656 die "default key ' $key ' is an alias - this is not allowed \n "
1657 if defined ( $phash ->{ alias
});
1658 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1659 if $phash ->{ keyAlias
};
1660 $default_key = $key ;
1662 my $key_alias = $phash ->{ keyAlias
};
1663 die "found keyAlias without 'alias definition for ' $key ' \n "
1664 if $key_alias && ! $phash ->{ alias
};
1666 if ( $phash ->{ alias
} && $key_alias ) {
1667 die "inconsistent keyAlias ' $key_alias ' definition"
1668 if defined ( $keyAliasProps ->{ $key_alias }) &&
1669 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1670 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1674 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1677 sub generate_typetext
{
1678 my ( $format, $list_enums ) = @_ ;
1680 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1685 my $add_option_string = sub {
1686 my ( $text, $optional ) = @_ ;
1692 $text = "[ $text ]" if $optional ;
1697 my $format_key_value = sub {
1698 my ( $key, $phash ) = @_ ;
1700 die "internal error" if defined ( $phash ->{ alias
});
1706 if ( my $desc = $phash ->{ format_description
}) {
1707 $typetext .= "< $desc >" ;
1708 } elsif ( my $text = $phash ->{ typetext
}) {
1710 } elsif ( my $enum = $phash ->{ enum
}) {
1711 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1712 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1714 $typetext .= '<enum>' ;
1716 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1717 $typetext .= '<1|0>' ;
1718 } elsif ( $phash ->{ type
} eq 'integer' ) {
1719 $typetext .= '<integer>' ;
1720 } elsif ( $phash ->{ type
} eq 'number' ) {
1721 $typetext .= '<number>' ;
1723 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1726 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1727 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1729 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1735 my $cond_add_key = sub {
1738 return if $done ->{ $key }; # avoid duplicates
1742 my $phash = $format ->{ $key };
1744 return if ! $phash ; # should not happen
1746 return if $phash ->{ alias
};
1748 & $format_key_value ( $key, $phash );
1752 & $cond_add_key ( $default_key ) if defined ( $default_key );
1754 # add required keys first
1755 foreach my $key ( sort keys %$format ) {
1756 my $phash = $format ->{ $key };
1757 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1761 foreach my $key ( sort keys %$format ) {
1762 & $cond_add_key ( $key );
1765 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1766 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1772 sub print_property_string
{
1773 my ( $data, $format, $skip, $path ) = @_ ;
1775 if ( ref ( $format ) ne 'HASH' ) {
1776 my $schema = get_format
( $format );
1777 die "not a valid format: $format\n " if ! $schema ;
1782 check_object
( $path, $format, $data, undef , $errors );
1783 if ( scalar ( %$errors )) {
1784 raise
"format error" , errors
=> $errors ;
1787 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1792 my $add_option_string = sub {
1795 $res .= ',' if $add_sep ;
1800 my $format_value = sub {
1801 my ( $key, $value, $format ) = @_ ;
1803 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1804 return format_size
( $value );
1806 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1811 my $done = { map { $_ => 1 } @$skip };
1813 my $cond_add_key = sub {
1814 my ( $key, $isdefault ) = @_ ;
1816 return if $done ->{ $key }; # avoid duplicates
1820 my $value = $data ->{ $key };
1822 return if ! defined ( $value );
1824 my $phash = $format ->{ $key };
1826 # try to combine values if we have key aliases
1827 if ( my $combine = $keyAliasProps ->{ $key }) {
1828 if ( defined ( my $combine_value = $data ->{ $combine })) {
1829 my $combine_format = $format ->{ $combine }->{ format
};
1830 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1831 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1832 & $add_option_string ( "${value_str}=${combine_str}" );
1833 $done ->{ $combine } = 1 ;
1838 if ( $phash && $phash ->{ alias
}) {
1839 $phash = $format ->{ $phash ->{ alias
}};
1842 die "invalid key ' $key ' \n " if ! $phash ;
1843 die "internal error" if defined ( $phash ->{ alias
});
1845 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1847 & $add_option_string ( $value_str );
1849 & $add_option_string ( " $key =${value_str}" );
1853 # add default key first
1854 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1856 # add required keys first
1857 foreach my $key ( sort keys %$data ) {
1858 my $phash = $format ->{ $key };
1859 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1863 foreach my $key ( sort keys %$data ) {
1864 & $cond_add_key ( $key );
1870 sub schema_get_type_text
{
1871 my ( $phash, $style ) = @_ ;
1873 my $type = $phash ->{ type
} || 'string' ;
1875 if ( $phash ->{ typetext
}) {
1876 return $phash ->{ typetext
};
1877 } elsif ( $phash ->{ format_description
}) {
1878 return "< $phash ->{format_description}>" ;
1879 } elsif ( $phash ->{ enum
}) {
1880 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
1881 } elsif ( $phash ->{ pattern
}) {
1882 return $phash ->{ pattern
};
1883 } elsif ( $type eq 'integer' || $type eq 'number' ) {
1884 # NOTE: always access values as number (avoid converion to string)
1885 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
1886 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
1887 ( $phash ->{ maximum
} + 0 ) . ")" ;
1888 } elsif ( defined ( $phash ->{ minimum
})) {
1889 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
1890 } elsif ( defined ( $phash ->{ maximum
})) {
1891 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
1893 } elsif ( $type eq 'string' ) {
1894 if ( my $format = $phash ->{ format
}) {
1895 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
1896 if ( ref ( $format ) eq 'HASH' ) {
1898 $list_enums = 1 if $style && $style eq 'config-sub' ;
1899 return generate_typetext
( $format, $list_enums );