]>
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 downloads the file content (filename is the return value of the method)." ,
1304 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1307 proxyto_callback
=> {
1309 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1314 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1316 additionalProperties
=> 0 ,
1319 description
=> "Describe access permissions." ,
1323 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1325 enum
=> [ 'all' , 'world' ],
1329 description
=> "Array of permission checks (prefix notation)." ,
1336 description
=> "Used internally" ,
1340 description
=> "Used internally" ,
1345 description
=> "path for URL matching (uri template)" ,
1347 fragmentDelimiter
=> {
1349 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." ,
1354 description
=> "JSON Schema for parameters." ,
1359 description
=> "JSON Schema for return value." ,
1364 description
=> "method implementation (code reference)" ,
1369 description
=> "Delegate call to this class (perl class string)." ,
1372 additionalProperties
=> 0 ,
1378 fragmentDelimiter
=> { optional
=> 1 }
1386 sub validate_schema
{
1389 my $errmsg = "internal error - unable to verify schema \n " ;
1390 validate
( $schema, $default_schema, $errmsg );
1393 sub validate_method_info
{
1396 my $errmsg = "internal error - unable to verify method info \n " ;
1397 validate
( $info, $method_schema, $errmsg );
1399 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1400 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1403 # run a self test on load
1404 # make sure we can verify the default schema
1405 validate_schema
( $default_schema_noref );
1406 validate_schema
( $method_schema );
1408 # and now some utility methods (used by pve api)
1409 sub method_get_child_link
{
1412 return undef if ! $info ;
1414 my $schema = $info ->{ returns
};
1415 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1417 my $links = $schema ->{ links
};
1418 return undef if ! $links ;
1421 foreach my $lnk ( @$links ) {
1422 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1431 # a way to parse command line parameters, using a
1432 # schema to configure Getopt::Long
1434 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1436 if (! $schema || ! $schema ->{ properties
}) {
1437 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1438 if scalar ( @$args ) != 0 ;
1443 if ( $arg_param && ! ref ( $arg_param )) {
1444 my $pd = $schema ->{ properties
}->{ $arg_param };
1445 die "expected list format $pd ->{format}"
1446 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1447 $list_param = $arg_param ;
1450 my @interactive = ();
1452 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1453 my $pd = $schema ->{ properties
}->{ $prop };
1454 next if $list_param && $prop eq $list_param ;
1455 next if defined ( $fixed_param ->{ $prop });
1457 my $mapping = $param_mapping_hash ->{ $prop };
1458 if ( $mapping && $mapping ->{ interactive
}) {
1459 # interactive parameters such as passwords: make the argument
1460 # optional and call the mapping function afterwards.
1461 push @getopt, " $prop :s" ;
1462 push @interactive, [ $prop, $mapping ->{ func
}];
1463 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1464 push @getopt, " $prop :s" ;
1466 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1467 push @getopt, " $prop =s@" ;
1469 push @getopt, " $prop =s" ;
1474 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1477 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1478 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1482 $opts ->{ $list_param } = $args ;
1484 } elsif ( ref ( $arg_param )) {
1485 foreach my $arg_name ( @$arg_param ) {
1486 if ( $opts ->{ 'extra-args' }) {
1487 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1489 if ( $arg_name eq 'extra-args' ) {
1490 $opts ->{ 'extra-args' } = $args ;
1494 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1495 $opts ->{ $arg_name } = shift @$args ;
1497 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1499 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1500 if scalar ( @$args ) != 0 ;
1503 if ( ref ( $arg_param )) {
1504 foreach my $arg_name ( @$arg_param ) {
1505 if ( $arg_name eq 'extra-args' ) {
1506 $opts ->{ 'extra-args' } = [];
1508 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1514 foreach my $entry ( @interactive ) {
1515 my ( $opt, $func ) = @$entry ;
1516 my $pd = $schema ->{ properties
}->{ $opt };
1517 my $value = $opts ->{ $opt };
1518 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1519 $opts ->{ $opt } = $func ->( $value );
1523 # decode after Getopt as we are not sure how well it handles unicode
1524 foreach my $p ( keys %$opts ) {
1525 if (! ref ( $opts ->{ $p })) {
1526 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1527 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1529 foreach my $v (@{ $opts ->{ $p }}) {
1530 push @$tmp, decode
( 'locale' , $v );
1533 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1534 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1536 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1540 foreach my $p ( keys %$opts ) {
1541 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1542 if ( $pd ->{ type
} eq 'boolean' ) {
1543 if ( $opts ->{ $p } eq '' ) {
1545 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1546 $opts ->{ $p } = $bool ;
1548 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1550 } elsif ( $pd ->{ format
}) {
1552 if ( $pd ->{ format
} =~ m/-list/ ) {
1553 # allow --vmid 100 --vmid 101 and --vmid 100,101
1554 # allow --dow mon --dow fri and --dow mon,fri
1555 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1556 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1557 # we encode array as \0 separated strings
1558 # Note: CGI.pm also use this encoding
1559 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1560 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1562 # st that split_list knows it is \0 terminated
1563 my $v = $opts ->{ $p }->[ 0 ];
1564 $opts ->{ $p } = " $v\0 " ;
1571 foreach my $p ( keys %$fixed_param ) {
1572 $opts ->{ $p } = $fixed_param ->{ $p };
1578 # A way to parse configuration data by giving a json schema
1580 my ( $schema, $filename, $raw ) = @_ ;
1582 # do fast check (avoid validate_schema($schema))
1583 die "got strange schema" if ! $schema ->{ type
} ||
1584 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1588 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1591 next if $line =~ /^#/ ;
1593 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1596 if ( $schema ->{ properties
}->{ $key } &&
1597 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1599 $value = parse_boolean
( $value ) // $value ;
1601 $cfg ->{ $key } = $value ;
1603 warn "ignore config line: $line\n "
1608 check_prop
( $cfg, $schema, '' , $errors );
1610 foreach my $k ( keys %$errors ) {
1611 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1618 # generate simple key/value file
1620 my ( $schema, $filename, $cfg ) = @_ ;
1622 # do fast check (avoid validate_schema($schema))
1623 die "got strange schema" if ! $schema ->{ type
} ||
1624 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1626 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1630 foreach my $k ( sort keys %$cfg ) {
1631 $data .= " $k : $cfg ->{ $k } \n " ;
1637 # helpers used to generate our manual pages
1639 my $find_schema_default_key = sub {
1643 my $keyAliasProps = {};
1645 foreach my $key ( keys %$format ) {
1646 my $phash = $format ->{ $key };
1647 if ( $phash ->{ default_key
}) {
1648 die "multiple default keys in schema ( $default_key, $key ) \n "
1649 if defined ( $default_key );
1650 die "default key ' $key ' is an alias - this is not allowed \n "
1651 if defined ( $phash ->{ alias
});
1652 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1653 if $phash ->{ keyAlias
};
1654 $default_key = $key ;
1656 my $key_alias = $phash ->{ keyAlias
};
1657 die "found keyAlias without 'alias definition for ' $key ' \n "
1658 if $key_alias && ! $phash ->{ alias
};
1660 if ( $phash ->{ alias
} && $key_alias ) {
1661 die "inconsistent keyAlias ' $key_alias ' definition"
1662 if defined ( $keyAliasProps ->{ $key_alias }) &&
1663 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1664 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1668 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1671 sub generate_typetext
{
1672 my ( $format, $list_enums ) = @_ ;
1674 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1679 my $add_option_string = sub {
1680 my ( $text, $optional ) = @_ ;
1686 $text = "[ $text ]" if $optional ;
1691 my $format_key_value = sub {
1692 my ( $key, $phash ) = @_ ;
1694 die "internal error" if defined ( $phash ->{ alias
});
1700 if ( my $desc = $phash ->{ format_description
}) {
1701 $typetext .= "< $desc >" ;
1702 } elsif ( my $text = $phash ->{ typetext
}) {
1704 } elsif ( my $enum = $phash ->{ enum
}) {
1705 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1706 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1708 $typetext .= '<enum>' ;
1710 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1711 $typetext .= '<1|0>' ;
1712 } elsif ( $phash ->{ type
} eq 'integer' ) {
1713 $typetext .= '<integer>' ;
1714 } elsif ( $phash ->{ type
} eq 'number' ) {
1715 $typetext .= '<number>' ;
1717 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1720 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1721 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1723 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1729 my $cond_add_key = sub {
1732 return if $done ->{ $key }; # avoid duplicates
1736 my $phash = $format ->{ $key };
1738 return if ! $phash ; # should not happen
1740 return if $phash ->{ alias
};
1742 & $format_key_value ( $key, $phash );
1746 & $cond_add_key ( $default_key ) if defined ( $default_key );
1748 # add required keys first
1749 foreach my $key ( sort keys %$format ) {
1750 my $phash = $format ->{ $key };
1751 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1755 foreach my $key ( sort keys %$format ) {
1756 & $cond_add_key ( $key );
1759 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1760 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1766 sub print_property_string
{
1767 my ( $data, $format, $skip, $path ) = @_ ;
1769 if ( ref ( $format ) ne 'HASH' ) {
1770 my $schema = get_format
( $format );
1771 die "not a valid format: $format\n " if ! $schema ;
1776 check_object
( $path, $format, $data, undef , $errors );
1777 if ( scalar ( %$errors )) {
1778 raise
"format error" , errors
=> $errors ;
1781 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1786 my $add_option_string = sub {
1789 $res .= ',' if $add_sep ;
1794 my $format_value = sub {
1795 my ( $key, $value, $format ) = @_ ;
1797 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1798 return format_size
( $value );
1800 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1805 my $done = { map { $_ => 1 } @$skip };
1807 my $cond_add_key = sub {
1808 my ( $key, $isdefault ) = @_ ;
1810 return if $done ->{ $key }; # avoid duplicates
1814 my $value = $data ->{ $key };
1816 return if ! defined ( $value );
1818 my $phash = $format ->{ $key };
1820 # try to combine values if we have key aliases
1821 if ( my $combine = $keyAliasProps ->{ $key }) {
1822 if ( defined ( my $combine_value = $data ->{ $combine })) {
1823 my $combine_format = $format ->{ $combine }->{ format
};
1824 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1825 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1826 & $add_option_string ( "${value_str}=${combine_str}" );
1827 $done ->{ $combine } = 1 ;
1832 if ( $phash && $phash ->{ alias
}) {
1833 $phash = $format ->{ $phash ->{ alias
}};
1836 die "invalid key ' $key ' \n " if ! $phash ;
1837 die "internal error" if defined ( $phash ->{ alias
});
1839 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1841 & $add_option_string ( $value_str );
1843 & $add_option_string ( " $key =${value_str}" );
1847 # add default key first
1848 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1850 # add required keys first
1851 foreach my $key ( sort keys %$data ) {
1852 my $phash = $format ->{ $key };
1853 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1857 foreach my $key ( sort keys %$data ) {
1858 & $cond_add_key ( $key );
1864 sub schema_get_type_text
{
1865 my ( $phash, $style ) = @_ ;
1867 my $type = $phash ->{ type
} || 'string' ;
1869 if ( $phash ->{ typetext
}) {
1870 return $phash ->{ typetext
};
1871 } elsif ( $phash ->{ format_description
}) {
1872 return "< $phash ->{format_description}>" ;
1873 } elsif ( $phash ->{ enum
}) {
1874 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
1875 } elsif ( $phash ->{ pattern
}) {
1876 return $phash ->{ pattern
};
1877 } elsif ( $type eq 'integer' || $type eq 'number' ) {
1878 # NOTE: always access values as number (avoid converion to string)
1879 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
1880 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
1881 ( $phash ->{ maximum
} + 0 ) . ")" ;
1882 } elsif ( defined ( $phash ->{ minimum
})) {
1883 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
1884 } elsif ( defined ( $phash ->{ maximum
})) {
1885 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
1887 } elsif ( $type eq 'string' ) {
1888 if ( my $format = $phash ->{ format
}) {
1889 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
1890 if ( ref ( $format ) eq 'HASH' ) {
1892 $list_enums = 1 if $style && $style eq 'config-sub' ;
1893 return generate_typetext
( $format, $list_enums );