]>
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 return parse_id
( $storeid, 'storage' , $noerr );
186 PVE
:: JSONSchema
:: register_format
( 'acme-plugin-id' , \
& parse_acme_plugin_id
);
187 sub parse_acme_plugin_id
{
188 my ( $pluginid, $noerr ) = @_ ;
190 return parse_id
( $pluginid, 'ACME plugin' , $noerr );
194 my ( $id, $type, $noerr ) = @_ ;
196 if ( $id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
197 return undef if $noerr ;
198 die " $type ID ' $id ' contains illegal characters \n " ;
203 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
204 sub pve_verify_vmid
{
205 my ( $vmid, $noerr ) = @_ ;
207 if ( $vmid !~ m/^[1-9][0-9]{2,8}$/ ) {
208 return undef if $noerr ;
209 die "value does not look like a valid VM ID \n " ;
214 register_format
( 'pve-node' , \
& pve_verify_node_name
);
215 sub pve_verify_node_name
{
216 my ( $node, $noerr ) = @_ ;
218 if ( $node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/ ) {
219 return undef if $noerr ;
220 die "value does not look like a valid node name \n " ;
226 my ( $idmap, $idformat ) = @_ ;
228 return undef if ! $idmap ;
232 foreach my $entry ( PVE
:: Tools
:: split_list
( $idmap )) {
234 $map ->{ identity
} = 1 ;
235 } elsif ( $entry =~ m/^([^:]+):([^:]+)$/ ) {
236 my ( $source, $target ) = ( $1, $2 );
238 check_format
( $idformat, $source, '' );
239 check_format
( $idformat, $target, '' );
241 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
243 die "duplicate mapping for source ' $source ' \n "
244 if exists $map ->{ entries
}->{ $source };
246 $map ->{ entries
}->{ $source } = $target ;
249 check_format
( $idformat, $entry );
251 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
253 die "default target ID can only be provided once \n "
254 if exists $map ->{ default };
256 $map ->{ default } = $entry ;
260 die "identity mapping cannot be combined with other mappings \n "
261 if $map ->{ identity
} && ( $map ->{ default } || exists $map ->{ entries
});
266 register_format
( 'storagepair' , \
& verify_storagepair
);
267 sub verify_storagepair
{
268 my ( $storagepair, $noerr ) = @_ ;
270 # note: this only checks a single list entry
271 # when using a storagepair-list map, you need to pass the full
272 # parameter to parse_idmap
273 eval { parse_idmap
( $storagepair, 'pve-storage-id' ) };
275 return undef if $noerr ;
282 register_format
( 'mac-addr' , \
& pve_verify_mac_addr
);
283 sub pve_verify_mac_addr
{
284 my ( $mac_addr, $noerr ) = @_ ;
286 # don't allow I/G bit to be set, most of the time it breaks things, see:
287 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
288 if ( $mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i ) {
289 return undef if $noerr ;
290 die "value does not look like a valid unicast MAC address \n " ;
295 register_standard_option
( 'mac-addr' , {
297 description
=> 'Unicast MAC address.' ,
298 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.' ,
299 format_description
=> "XX:XX:XX:XX:XX:XX" ,
301 format
=> 'mac-addr' ,
304 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
305 sub pve_verify_ipv4
{
306 my ( $ipv4, $noerr ) = @_ ;
308 if ( $ipv4 !~ m/^(?:$IPV4RE)$/ ) {
309 return undef if $noerr ;
310 die "value does not look like a valid IPv4 address \n " ;
315 register_format
( 'ipv6' , \
& pve_verify_ipv6
);
316 sub pve_verify_ipv6
{
317 my ( $ipv6, $noerr ) = @_ ;
319 if ( $ipv6 !~ m/^(?:$IPV6RE)$/ ) {
320 return undef if $noerr ;
321 die "value does not look like a valid IPv6 address \n " ;
326 register_format
( 'ip' , \
& pve_verify_ip
);
328 my ( $ip, $noerr ) = @_ ;
330 if ( $ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/ ) {
331 return undef if $noerr ;
332 die "value does not look like a valid IP address \n " ;
337 PVE
:: JSONSchema
:: register_format
( 'ldap-simple-attr' , \
& verify_ldap_simple_attr
);
338 sub verify_ldap_simple_attr
{
339 my ( $attr, $noerr ) = @_ ;
341 if ( $attr =~ m/^[a-zA-Z0-9]+$/ ) {
345 die "value ' $attr ' does not look like a simple ldap attribute name \n " if ! $noerr ;
350 my $ipv4_mask_hash = {
368 '255.255.128.0' => 17 ,
369 '255.255.192.0' => 18 ,
370 '255.255.224.0' => 19 ,
371 '255.255.240.0' => 20 ,
372 '255.255.248.0' => 21 ,
373 '255.255.252.0' => 22 ,
374 '255.255.254.0' => 23 ,
375 '255.255.255.0' => 24 ,
376 '255.255.255.128' => 25 ,
377 '255.255.255.192' => 26 ,
378 '255.255.255.224' => 27 ,
379 '255.255.255.240' => 28 ,
380 '255.255.255.248' => 29 ,
381 '255.255.255.252' => 30 ,
382 '255.255.255.254' => 31 ,
383 '255.255.255.255' => 32 ,
386 sub get_netmask_bits
{
388 return $ipv4_mask_hash ->{ $mask };
391 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
392 sub pve_verify_ipv4mask
{
393 my ( $mask, $noerr ) = @_ ;
395 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
396 return undef if $noerr ;
397 die "value does not look like a valid IP netmask \n " ;
402 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
403 sub pve_verify_cidrv6
{
404 my ( $cidr, $noerr ) = @_ ;
406 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
410 return undef if $noerr ;
411 die "value does not look like a valid IPv6 CIDR network \n " ;
414 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
415 sub pve_verify_cidrv4
{
416 my ( $cidr, $noerr ) = @_ ;
418 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
422 return undef if $noerr ;
423 die "value does not look like a valid IPv4 CIDR network \n " ;
426 register_format
( 'CIDR' , \
& pve_verify_cidr
);
427 sub pve_verify_cidr
{
428 my ( $cidr, $noerr ) = @_ ;
430 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
431 pve_verify_cidrv6
( $cidr, 1 )))
433 return undef if $noerr ;
434 die "value does not look like a valid CIDR network \n " ;
440 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
441 sub pve_verify_ipv4_config
{
442 my ( $config, $noerr ) = @_ ;
444 return $config if $config =~ /^(?:dhcp|manual)$/ ||
445 pve_verify_cidrv4
( $config, 1 );
446 return undef if $noerr ;
447 die "value does not look like a valid ipv4 network configuration \n " ;
450 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
451 sub pve_verify_ipv6_config
{
452 my ( $config, $noerr ) = @_ ;
454 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
455 pve_verify_cidrv6
( $config, 1 );
456 return undef if $noerr ;
457 die "value does not look like a valid ipv6 network configuration \n " ;
460 register_format
( 'email' , \
& pve_verify_email
);
461 sub pve_verify_email
{
462 my ( $email, $noerr ) = @_ ;
464 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
465 return undef if $noerr ;
466 die "value does not look like a valid email address \n " ;
471 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
472 sub pve_verify_dns_name
{
473 my ( $name, $noerr ) = @_ ;
475 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
477 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
478 return undef if $noerr ;
479 die "value does not look like a valid DNS name \n " ;
484 # network interface name
485 register_format
( 'pve-iface' , \
& pve_verify_iface
);
486 sub pve_verify_iface
{
487 my ( $id, $noerr ) = @_ ;
489 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
490 return undef if $noerr ;
491 die "invalid network interface name ' $id ' \n " ;
496 # general addresses by name or IP
497 register_format
( 'address' , \
& pve_verify_address
);
498 sub pve_verify_address
{
499 my ( $addr, $noerr ) = @_ ;
501 if (!( pve_verify_ip
( $addr, 1 ) ||
502 pve_verify_dns_name
( $addr, 1 )))
504 return undef if $noerr ;
505 die "value does not look like a valid address: $addr\n " ;
510 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
511 sub pve_verify_disk_size
{
512 my ( $size, $noerr ) = @_ ;
513 if (! defined ( parse_size
( $size ))) {
514 return undef if $noerr ;
515 die "value does not look like a valid disk size: $size\n " ;
520 register_standard_option
( 'spice-proxy' , {
521 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)." ,
522 type
=> 'string' , format
=> 'address' ,
525 register_standard_option
( 'remote-viewer-config' , {
526 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
527 additionalProperties
=> 1 ,
529 type
=> { type
=> 'string' },
530 password
=> { type
=> 'string' },
531 proxy
=> { type
=> 'string' },
532 host
=> { type
=> 'string' },
533 'tls-port' => { type
=> 'integer' },
537 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
538 sub pve_verify_startup_order
{
539 my ( $value, $noerr ) = @_ ;
541 return $value if pve_parse_startup_order
( $value );
543 return undef if $noerr ;
545 die "unable to parse startup options \n " ;
550 type
=> 'number' , minimum
=> '0' ,
551 format_description
=> 'LIMIT' ,
554 my $bwlimit_format = {
557 description
=> 'default bandwidth limit in KiB/s' ,
561 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
565 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
569 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
573 description
=> 'bandwidth limit in KiB/s for moving disks' ,
576 register_format
( 'bwlimit' , $bwlimit_format );
577 register_standard_option
( 'bwlimit' , {
578 description
=> "Set bandwidth/io limits various operations." ,
581 format
=> $bwlimit_format,
584 # used for pve-tag-list in e.g., guest configs
585 register_format
( 'pve-tag' , \
& pve_verify_tag
);
587 my ( $value, $noerr ) = @_ ;
589 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i ;
591 return undef if $noerr ;
593 die "invalid characters in tag \n " ;
596 sub pve_parse_startup_order
{
599 return undef if ! $value ;
603 foreach my $p ( split ( /,/ , $value )) {
604 next if $p =~ m/^\s*$/ ;
606 if ( $p =~ m/^(order=)?(\d+)$/ ) {
608 } elsif ( $p =~ m/^up=(\d+)$/ ) {
610 } elsif ( $p =~ m/^down=(\d+)$/ ) {
620 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
621 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." ,
623 type
=> 'string' , format
=> 'pve-startup-order' ,
624 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
627 register_format
( 'pve-tfa-secret' , \
& pve_verify_tfa_secret
);
628 sub pve_verify_tfa_secret
{
629 my ( $key, $noerr ) = @_ ;
631 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
632 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
633 # format to support arbitrary lengths properly:
634 if ( $key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
635 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
636 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/ ) # and the old pattern copy&pasted
641 return undef if $noerr ;
643 die "unable to decode TFA secret \n " ;
647 my ( $format, $value, $path ) = @_ ;
649 return parse_property_string
( $format, $value, $path ) if ref ( $format ) eq 'HASH' ;
650 return if $format eq 'regex' ;
652 if ( $format =~ m/^(.*)-a?list$/ ) {
654 my $code = $format_list ->{ $1 };
656 die "undefined format ' $format ' \n " if ! $code ;
658 # Note: we allow empty lists
659 foreach my $v ( split_list
( $value )) {
663 } elsif ( $format =~ m/^(.*)-opt$/ ) {
665 my $code = $format_list ->{ $1 };
667 die "undefined format ' $format ' \n " if ! $code ;
669 return if ! $value ; # allow empty string
675 my $code = $format_list ->{ $format };
677 die "undefined format ' $format ' \n " if ! $code ;
679 return parse_property_string
( $code, $value, $path ) if ref ( $code ) eq 'HASH' ;
687 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
688 my ( $size, $unit ) = ( $1, $3 );
691 $size = $size * 1024 ;
692 } elsif ( $unit eq 'M' ) {
693 $size = $size * 1024 * 1024 ;
694 } elsif ( $unit eq 'G' ) {
695 $size = $size * 1024 * 1024 * 1024 ;
696 } elsif ( $unit eq 'T' ) {
697 $size = $size * 1024 * 1024 * 1024 * 1024 ;
708 my $kb = int ( $size/1024 );
709 return $size if $kb*1024 != $size ;
711 my $mb = int ( $kb/1024 );
712 return "${kb}K" if $mb*1024 != $kb ;
714 my $gb = int ( $mb/1024 );
715 return "${mb}M" if $gb*1024 != $mb ;
717 my $tb = int ( $gb/1024 );
718 return "${gb}G" if $tb*1024 != $gb ;
725 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
726 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
730 sub parse_property_string
{
731 my ( $format, $data, $path, $additional_properties ) = @_ ;
733 # In property strings we default to not allowing additional properties
734 $additional_properties = 0 if ! defined ( $additional_properties );
736 # Support named formats here, too:
738 if ( my $desc = $format_list ->{ $format }) {
741 die "unknown format: $format\n " ;
743 } elsif ( ref ( $format ) ne 'HASH' ) {
744 die "unexpected format value of type " . ref ( $format ). " \n " ;
750 foreach my $part ( split ( /,/ , $data )) {
751 next if $part =~ /^\s*$/ ;
753 if ( $part =~ /^([^=]+)=(.+)$/ ) {
754 my ( $k, $v ) = ( $1, $2 );
755 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
756 my $schema = $format ->{ $k };
757 if ( my $alias = $schema ->{ alias
}) {
758 if ( my $key_alias = $schema ->{ keyAlias
}) {
759 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
760 $res ->{ $key_alias } = $k ;
763 $schema = $format ->{ $k };
766 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
767 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
768 $v = parse_boolean
( $v ) // $v ;
771 } elsif ( $part !~ /=/ ) {
772 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
773 foreach my $key ( keys %$format ) {
774 if ( $format ->{ $key }->{ default_key
}) {
776 if (! $res ->{ $default_key }) {
777 $res ->{ $default_key } = $part ;
780 die "duplicate key in comma-separated list property: $default_key\n " ;
783 die "value without key, but schema does not define a default key \n " if ! $default_key ;
785 die "missing key in comma-separated list property \n " ;
790 check_object
( $path, $format, $res, $additional_properties, $errors );
791 if ( scalar ( %$errors )) {
792 raise
"format error \n " , errors
=> $errors ;
799 my ( $errors, $path, $msg ) = @_ ;
801 $path = '_root' if ! $path ;
803 if ( $errors ->{ $path }) {
804 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
806 $errors ->{ $path } = $msg ;
813 # see 'man perlretut'
814 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
820 return $value =~ m/^[+-]?\d+$/ ;
824 my ( $path, $type, $value, $errors ) = @_ ;
828 if (! defined ( $value )) {
829 return 1 if $type eq 'null' ;
833 if ( my $tt = ref ( $type )) {
834 if ( $tt eq 'ARRAY' ) {
835 foreach my $t ( @$type ) {
837 check_type
( $path, $t, $value, $tmperr );
838 return 1 if ! scalar ( %$tmperr );
840 my $ttext = join ( '|' , @$type );
841 add_error
( $errors, $path, "type check (' $ttext ') failed" );
843 } elsif ( $tt eq 'HASH' ) {
845 check_prop
( $value, $type, $path, $tmperr );
846 return 1 if ! scalar ( %$tmperr );
847 add_error
( $errors, $path, "type check failed" );
850 die "internal error - got reference type ' $tt '" ;
855 return 1 if $type eq 'any' ;
857 if ( $type eq 'null' ) {
858 if ( defined ( $value )) {
859 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
865 my $vt = ref ( $value );
867 if ( $type eq 'array' ) {
868 if (! $vt || $vt ne 'ARRAY' ) {
869 add_error
( $errors, $path, "type check (' $type ') failed" );
873 } elsif ( $type eq 'object' ) {
874 if (! $vt || $vt ne 'HASH' ) {
875 add_error
( $errors, $path, "type check (' $type ') failed" );
879 } elsif ( $type eq 'coderef' ) {
880 if (! $vt || $vt ne 'CODE' ) {
881 add_error
( $errors, $path, "type check (' $type ') failed" );
885 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
886 # qr// regexes can be used as strings and make sense for format=regex
890 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
893 if ( $type eq 'string' ) {
894 return 1 ; # nothing to check ?
895 } elsif ( $type eq 'boolean' ) {
896 #if ($value =~ m/^(1|true|yes|on)$/i) {
899 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
900 } elsif ( $value eq '0' ) {
901 return 1 ; # return success (not value)
903 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
906 } elsif ( $type eq 'integer' ) {
907 if (! is_integer
( $value )) {
908 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
912 } elsif ( $type eq 'number' ) {
913 if (! is_number
( $value )) {
914 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
919 return 1 ; # no need to verify unknown types
929 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
931 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
933 my $st = ref ( $schema );
934 if (! $st || $st ne 'HASH' ) {
935 add_error
( $errors, $path, "Invalid schema definition." );
939 my $vt = ref ( $value );
940 if (! $vt || $vt ne 'HASH' ) {
941 add_error
( $errors, $path, "an object is required" );
945 foreach my $k ( keys %$schema ) {
946 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
949 foreach my $k ( keys %$value ) {
951 my $newpath = $path ?
" $path . $k " : $k ;
953 if ( my $subschema = $schema ->{ $k }) {
954 if ( my $requires = $subschema ->{ requires
}) {
955 if ( ref ( $requires )) {
956 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
957 check_prop
( $value, $requires, $path, $errors );
958 } elsif (! defined ( $value ->{ $requires })) {
959 add_error
( $errors, $path ?
" $path . $requires " : $requires,
960 "missing property - ' $newpath ' requires this property" );
964 next ; # value is already checked above
967 if ( defined ( $additional_properties ) && ! $additional_properties ) {
968 add_error
( $errors, $newpath, "property is not defined in schema " .
969 "and the schema does not allow additional properties" );
972 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
973 if ref ( $additional_properties );
977 sub check_object_warn
{
978 my ( $path, $schema, $value, $additional_properties ) = @_ ;
980 check_object
( $path, $schema, $value, $additional_properties, $errors );
981 if ( scalar ( %$errors )) {
982 foreach my $k ( keys %$errors ) {
983 warn "parse error: $k : $errors ->{ $k } \n " ;
991 my ( $value, $schema, $path, $errors ) = @_ ;
993 die "internal error - no schema" if ! $schema ;
994 die "internal error" if ! $errors ;
996 #print "check_prop $path\n" if $value;
998 my $st = ref ( $schema );
999 if (! $st || $st ne 'HASH' ) {
1000 add_error
( $errors, $path, "Invalid schema definition." );
1004 # if it extends another schema, it must pass that schema as well
1005 if ( $schema ->{ extends
}) {
1006 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
1009 if (! defined ( $value )) {
1010 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
1011 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
1012 add_error
( $errors, $path, "property is missing and it is not optional" );
1017 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
1019 if ( $schema ->{ disallow
}) {
1021 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
1022 add_error
( $errors, $path, "disallowed value was matched" );
1027 if ( my $vt = ref ( $value )) {
1029 if ( $vt eq 'ARRAY' ) {
1030 if ( $schema ->{ items
}) {
1031 my $it = ref ( $schema ->{ items
});
1032 if ( $it && $it eq 'ARRAY' ) {
1033 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1034 die "not implemented" ;
1037 foreach my $el ( @$value ) {
1038 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
1044 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
1045 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
1046 $value, $schema ->{ additionalProperties
}, $errors );
1052 if ( my $format = $schema ->{ format
}) {
1053 eval { check_format
( $format, $value, $path ); };
1055 add_error
( $errors, $path, "invalid format - $@ " );
1060 if ( my $pattern = $schema ->{ pattern
}) {
1061 if ( $value !~ m/^$pattern$/ ) {
1062 add_error
( $errors, $path, "value does not match the regex pattern" );
1067 if ( defined ( my $max = $schema ->{ maxLength
})) {
1068 if ( length ( $value ) > $max ) {
1069 add_error
( $errors, $path, "value may only be $max characters long" );
1074 if ( defined ( my $min = $schema ->{ minLength
})) {
1075 if ( length ( $value ) < $min ) {
1076 add_error
( $errors, $path, "value must be at least $min characters long" );
1081 if ( is_number
( $value )) {
1082 if ( defined ( my $max = $schema ->{ maximum
})) {
1083 if ( $value > $max ) {
1084 add_error
( $errors, $path, "value must have a maximum value of $max " );
1089 if ( defined ( my $min = $schema ->{ minimum
})) {
1090 if ( $value < $min ) {
1091 add_error
( $errors, $path, "value must have a minimum value of $min " );
1097 if ( my $ea = $schema ->{ enum
}) {
1100 foreach my $ev ( @$ea ) {
1101 if ( $ev eq $value ) {
1107 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
1108 join ( ", " , @$ea ) . "'" );
1115 my ( $instance, $schema, $errmsg ) = @_ ;
1118 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1120 # todo: cycle detection is only needed for debugging, I guess
1121 # we can disable that in the final release
1122 # todo: is there a better/faster way to detect cycles?
1124 find_cycle
( $instance, sub { $cycles = 1 });
1126 add_error
( $errors, undef , "data structure contains recursive cycles" );
1128 check_prop
( $instance, $schema, '' , $errors );
1131 if ( scalar ( %$errors )) {
1132 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1138 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1139 my $default_schema_noref = {
1140 description
=> "This is the JSON Schema for JSON Schemas." ,
1141 type
=> [ "object" ],
1142 additionalProperties
=> 0 ,
1145 type
=> [ "string" , "array" ],
1146 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1151 enum
=> $schema_valid_types,
1153 enum
=> $schema_valid_types,
1157 description
=> "This indicates that the instance property in the instance object is not required." ,
1163 description
=> "This is a definition for the properties of an object value" ,
1169 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1173 additionalProperties
=> {
1174 type
=> [ "boolean" , "object" ],
1175 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1182 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1187 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1191 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1198 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1204 description
=> "A text representation of the type (used to generate documentation)." ,
1209 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." ,
1216 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1221 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)." ,
1223 verbose_description
=> {
1226 description
=> "This provides a more verbose description." ,
1228 format_description
=> {
1231 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1236 description
=> "This provides the title of the property" ,
1241 description
=> "This is used to provide rendering hints to format cli command output." ,
1244 type
=> [ "string" , "object" ],
1246 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1249 type
=> [ "string" , "object" ],
1251 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" ,
1256 description
=> "Whether this is the default key in a comma separated list property string." ,
1261 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." ,
1266 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1267 requires
=> 'alias' ,
1272 description
=> "This indicates the default for the instance property."
1276 description
=> "Bash completion function. This function should return a list of possible values." ,
1282 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." ,
1287 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1290 # this is from hyper schema
1293 description
=> "This defines the link relations of the instance objects" ,
1300 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" ,
1304 description
=> "This is the name of the link relation" ,
1310 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1319 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1325 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1327 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1328 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1330 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1331 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1333 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1334 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1336 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1337 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1339 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1340 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1342 my $method_schema = {
1344 additionalProperties
=> 0 ,
1347 description
=> "This a description of the method" ,
1352 description
=> "This indicates the name of the function to call." ,
1355 additionalProperties
=> 1 ,
1370 description
=> "The HTTP method name." ,
1371 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1376 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1381 description
=> "Method is available for clients authenticated using an API token." ,
1387 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1392 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1395 proxyto_callback
=> {
1397 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1402 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1404 additionalProperties
=> 0 ,
1407 description
=> "Describe access permissions." ,
1411 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1413 enum
=> [ 'all' , 'world' ],
1417 description
=> "Array of permission checks (prefix notation)." ,
1424 description
=> "Used internally" ,
1428 description
=> "Used internally" ,
1433 description
=> "path for URL matching (uri template)" ,
1435 fragmentDelimiter
=> {
1437 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." ,
1442 description
=> "JSON Schema for parameters." ,
1447 description
=> "JSON Schema for return value." ,
1452 description
=> "method implementation (code reference)" ,
1457 description
=> "Delegate call to this class (perl class string)." ,
1460 additionalProperties
=> 0 ,
1466 fragmentDelimiter
=> { optional
=> 1 }
1474 sub validate_schema
{
1477 my $errmsg = "internal error - unable to verify schema \n " ;
1478 validate
( $schema, $default_schema, $errmsg );
1481 sub validate_method_info
{
1484 my $errmsg = "internal error - unable to verify method info \n " ;
1485 validate
( $info, $method_schema, $errmsg );
1487 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1488 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1491 # run a self test on load
1492 # make sure we can verify the default schema
1493 validate_schema
( $default_schema_noref );
1494 validate_schema
( $method_schema );
1496 # and now some utility methods (used by pve api)
1497 sub method_get_child_link
{
1500 return undef if ! $info ;
1502 my $schema = $info ->{ returns
};
1503 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1505 my $links = $schema ->{ links
};
1506 return undef if ! $links ;
1509 foreach my $lnk ( @$links ) {
1510 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1519 # a way to parse command line parameters, using a
1520 # schema to configure Getopt::Long
1522 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1524 if (! $schema || ! $schema ->{ properties
}) {
1525 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1526 if scalar ( @$args ) != 0 ;
1531 if ( $arg_param && ! ref ( $arg_param )) {
1532 my $pd = $schema ->{ properties
}->{ $arg_param };
1533 die "expected list format $pd ->{format}"
1534 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1535 $list_param = $arg_param ;
1538 my @interactive = ();
1540 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1541 my $pd = $schema ->{ properties
}->{ $prop };
1542 next if $list_param && $prop eq $list_param ;
1543 next if defined ( $fixed_param ->{ $prop });
1545 my $mapping = $param_mapping_hash ->{ $prop };
1546 if ( $mapping && $mapping ->{ interactive
}) {
1547 # interactive parameters such as passwords: make the argument
1548 # optional and call the mapping function afterwards.
1549 push @getopt, " $prop :s" ;
1550 push @interactive, [ $prop, $mapping ->{ func
}];
1551 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1552 push @getopt, " $prop :s" ;
1554 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1555 push @getopt, " $prop =s@" ;
1557 push @getopt, " $prop =s" ;
1562 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1565 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1566 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1570 $opts ->{ $list_param } = $args ;
1572 } elsif ( ref ( $arg_param )) {
1573 foreach my $arg_name ( @$arg_param ) {
1574 if ( $opts ->{ 'extra-args' }) {
1575 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1577 if ( $arg_name eq 'extra-args' ) {
1578 $opts ->{ 'extra-args' } = $args ;
1582 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1583 $opts ->{ $arg_name } = shift @$args ;
1585 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1587 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1588 if scalar ( @$args ) != 0 ;
1591 if ( ref ( $arg_param )) {
1592 foreach my $arg_name ( @$arg_param ) {
1593 if ( $arg_name eq 'extra-args' ) {
1594 $opts ->{ 'extra-args' } = [];
1596 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1602 foreach my $entry ( @interactive ) {
1603 my ( $opt, $func ) = @$entry ;
1604 my $pd = $schema ->{ properties
}->{ $opt };
1605 my $value = $opts ->{ $opt };
1606 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1607 $opts ->{ $opt } = $func ->( $value );
1611 # decode after Getopt as we are not sure how well it handles unicode
1612 foreach my $p ( keys %$opts ) {
1613 if (! ref ( $opts ->{ $p })) {
1614 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1615 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1617 foreach my $v (@{ $opts ->{ $p }}) {
1618 push @$tmp, decode
( 'locale' , $v );
1621 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1622 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1624 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1628 foreach my $p ( keys %$opts ) {
1629 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1630 if ( $pd ->{ type
} eq 'boolean' ) {
1631 if ( $opts ->{ $p } eq '' ) {
1633 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1634 $opts ->{ $p } = $bool ;
1636 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1638 } elsif ( $pd ->{ format
}) {
1640 if ( $pd ->{ format
} =~ m/-list/ ) {
1641 # allow --vmid 100 --vmid 101 and --vmid 100,101
1642 # allow --dow mon --dow fri and --dow mon,fri
1643 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1644 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1645 # we encode array as \0 separated strings
1646 # Note: CGI.pm also use this encoding
1647 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1648 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1650 # st that split_list knows it is \0 terminated
1651 my $v = $opts ->{ $p }->[ 0 ];
1652 $opts ->{ $p } = " $v\0 " ;
1659 foreach my $p ( keys %$fixed_param ) {
1660 $opts ->{ $p } = $fixed_param ->{ $p };
1666 # A way to parse configuration data by giving a json schema
1668 my ( $schema, $filename, $raw ) = @_ ;
1670 # do fast check (avoid validate_schema($schema))
1671 die "got strange schema" if ! $schema ->{ type
} ||
1672 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1676 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1679 next if $line =~ /^#/ ;
1681 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1684 if ( $schema ->{ properties
}->{ $key } &&
1685 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1687 $value = parse_boolean
( $value ) // $value ;
1689 $cfg ->{ $key } = $value ;
1691 warn "ignore config line: $line\n "
1696 check_prop
( $cfg, $schema, '' , $errors );
1698 foreach my $k ( keys %$errors ) {
1699 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1706 # generate simple key/value file
1708 my ( $schema, $filename, $cfg ) = @_ ;
1710 # do fast check (avoid validate_schema($schema))
1711 die "got strange schema" if ! $schema ->{ type
} ||
1712 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1714 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1718 foreach my $k ( sort keys %$cfg ) {
1719 $data .= " $k : $cfg ->{ $k } \n " ;
1725 # helpers used to generate our manual pages
1727 my $find_schema_default_key = sub {
1731 my $keyAliasProps = {};
1733 foreach my $key ( keys %$format ) {
1734 my $phash = $format ->{ $key };
1735 if ( $phash ->{ default_key
}) {
1736 die "multiple default keys in schema ( $default_key, $key ) \n "
1737 if defined ( $default_key );
1738 die "default key ' $key ' is an alias - this is not allowed \n "
1739 if defined ( $phash ->{ alias
});
1740 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1741 if $phash ->{ keyAlias
};
1742 $default_key = $key ;
1744 my $key_alias = $phash ->{ keyAlias
};
1745 die "found keyAlias without 'alias definition for ' $key ' \n "
1746 if $key_alias && ! $phash ->{ alias
};
1748 if ( $phash ->{ alias
} && $key_alias ) {
1749 die "inconsistent keyAlias ' $key_alias ' definition"
1750 if defined ( $keyAliasProps ->{ $key_alias }) &&
1751 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1752 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1756 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1759 sub generate_typetext
{
1760 my ( $format, $list_enums ) = @_ ;
1762 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1767 my $add_option_string = sub {
1768 my ( $text, $optional ) = @_ ;
1774 $text = "[ $text ]" if $optional ;
1779 my $format_key_value = sub {
1780 my ( $key, $phash ) = @_ ;
1782 die "internal error" if defined ( $phash ->{ alias
});
1788 if ( my $desc = $phash ->{ format_description
}) {
1789 $typetext .= "< $desc >" ;
1790 } elsif ( my $text = $phash ->{ typetext
}) {
1792 } elsif ( my $enum = $phash ->{ enum
}) {
1793 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1794 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1796 $typetext .= '<enum>' ;
1798 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1799 $typetext .= '<1|0>' ;
1800 } elsif ( $phash ->{ type
} eq 'integer' ) {
1801 $typetext .= '<integer>' ;
1802 } elsif ( $phash ->{ type
} eq 'number' ) {
1803 $typetext .= '<number>' ;
1805 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1808 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1809 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1811 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1817 my $cond_add_key = sub {
1820 return if $done ->{ $key }; # avoid duplicates
1824 my $phash = $format ->{ $key };
1826 return if ! $phash ; # should not happen
1828 return if $phash ->{ alias
};
1830 & $format_key_value ( $key, $phash );
1834 & $cond_add_key ( $default_key ) if defined ( $default_key );
1836 # add required keys first
1837 foreach my $key ( sort keys %$format ) {
1838 my $phash = $format ->{ $key };
1839 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1843 foreach my $key ( sort keys %$format ) {
1844 & $cond_add_key ( $key );
1847 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1848 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1854 sub print_property_string
{
1855 my ( $data, $format, $skip, $path ) = @_ ;
1857 if ( ref ( $format ) ne 'HASH' ) {
1858 my $schema = get_format
( $format );
1859 die "not a valid format: $format\n " if ! $schema ;
1864 check_object
( $path, $format, $data, undef , $errors );
1865 if ( scalar ( %$errors )) {
1866 raise
"format error" , errors
=> $errors ;
1869 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1874 my $add_option_string = sub {
1877 $res .= ',' if $add_sep ;
1882 my $format_value = sub {
1883 my ( $key, $value, $format ) = @_ ;
1885 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1886 return format_size
( $value );
1888 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1893 my $done = { map { $_ => 1 } @$skip };
1895 my $cond_add_key = sub {
1896 my ( $key, $isdefault ) = @_ ;
1898 return if $done ->{ $key }; # avoid duplicates
1902 my $value = $data ->{ $key };
1904 return if ! defined ( $value );
1906 my $phash = $format ->{ $key };
1908 # try to combine values if we have key aliases
1909 if ( my $combine = $keyAliasProps ->{ $key }) {
1910 if ( defined ( my $combine_value = $data ->{ $combine })) {
1911 my $combine_format = $format ->{ $combine }->{ format
};
1912 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1913 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1914 & $add_option_string ( "${value_str}=${combine_str}" );
1915 $done ->{ $combine } = 1 ;
1920 if ( $phash && $phash ->{ alias
}) {
1921 $phash = $format ->{ $phash ->{ alias
}};
1924 die "invalid key ' $key ' \n " if ! $phash ;
1925 die "internal error" if defined ( $phash ->{ alias
});
1927 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1929 & $add_option_string ( $value_str );
1931 & $add_option_string ( " $key =${value_str}" );
1935 # add default key first
1936 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1938 # add required keys first
1939 foreach my $key ( sort keys %$data ) {
1940 my $phash = $format ->{ $key };
1941 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1945 foreach my $key ( sort keys %$data ) {
1946 & $cond_add_key ( $key );
1952 sub schema_get_type_text
{
1953 my ( $phash, $style ) = @_ ;
1955 my $type = $phash ->{ type
} || 'string' ;
1957 if ( $phash ->{ typetext
}) {
1958 return $phash ->{ typetext
};
1959 } elsif ( $phash ->{ format_description
}) {
1960 return "< $phash ->{format_description}>" ;
1961 } elsif ( $phash ->{ enum
}) {
1962 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
1963 } elsif ( $phash ->{ pattern
}) {
1964 return $phash ->{ pattern
};
1965 } elsif ( $type eq 'integer' || $type eq 'number' ) {
1966 # NOTE: always access values as number (avoid converion to string)
1967 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
1968 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
1969 ( $phash ->{ maximum
} + 0 ) . ")" ;
1970 } elsif ( defined ( $phash ->{ minimum
})) {
1971 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
1972 } elsif ( defined ( $phash ->{ maximum
})) {
1973 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
1975 } elsif ( $type eq 'string' ) {
1976 if ( my $format = $phash ->{ format
}) {
1977 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
1978 if ( ref ( $format ) eq 'HASH' ) {
1980 $list_enums = 1 if $style && $style eq 'config-sub' ;
1981 return generate_typetext
( $format, $list_enums );