]>
git.proxmox.com Git - pve-common.git/blob - src/PVE/JSONSchema.pm
275c20adc74f86cd37b92a63df3d6b955a11edae
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) ;
21 register_standard_option
24 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
25 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
26 # see: http://json-schema.org/
28 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
30 my $standard_options = {};
31 sub register_standard_option
{
32 my ( $name, $schema ) = @_ ;
34 die "standard option ' $name ' already registered \n "
35 if $standard_options ->{ $name };
37 $standard_options ->{ $name } = $schema ;
40 sub get_standard_option
{
41 my ( $name, $base ) = @_ ;
43 my $std = $standard_options ->{ $name };
44 die "no such standard option ' $name ' \n " if ! $std ;
46 my $res = $base || {};
48 foreach my $opt ( keys %$std ) {
49 next if defined ( $res ->{ $opt });
50 $res ->{ $opt } = $std ->{ $opt };
56 register_standard_option
( 'pve-vmid' , {
57 description
=> "The (unique) ID of the VM." ,
58 type
=> 'integer' , format
=> 'pve-vmid' ,
62 register_standard_option
( 'pve-node' , {
63 description
=> "The cluster node name." ,
64 type
=> 'string' , format
=> 'pve-node' ,
67 register_standard_option
( 'pve-node-list' , {
68 description
=> "List of cluster node names." ,
69 type
=> 'string' , format
=> 'pve-node-list' ,
72 register_standard_option
( 'pve-iface' , {
73 description
=> "Network interface name." ,
74 type
=> 'string' , format
=> 'pve-iface' ,
75 minLength
=> 2 , maxLength
=> 20 ,
78 register_standard_option
( 'pve-storage-id' , {
79 description
=> "The storage identifier." ,
80 type
=> 'string' , format
=> 'pve-storage-id' ,
83 register_standard_option
( 'pve-config-digest' , {
84 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.' ,
87 maxLength
=> 40 , # sha1 hex digest length is 40
90 register_standard_option
( 'skiplock' , {
91 description
=> "Ignore locks - only root is allowed to use this option." ,
96 register_standard_option
( 'extra-args' , {
97 description
=> "Extra arguments as array" ,
99 items
=> { type
=> 'string' },
103 register_standard_option
( 'fingerprint-sha256' , {
104 description
=> "Certificate SHA 256 fingerprint." ,
106 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}' ,
109 register_standard_option
( 'pve-output-format' , {
111 description
=> 'Output format.' ,
112 enum
=> [ 'text' , 'json' , 'json-pretty' , 'yaml' ],
117 register_standard_option
( 'pve-snapshot-name' , {
118 description
=> "The name of the snapshot." ,
119 type
=> 'string' , format
=> 'pve-configid' ,
123 my $format_list = {};
125 sub register_format
{
126 my ( $format, $code ) = @_ ;
128 die "JSON schema format ' $format ' already registered \n "
129 if $format_list ->{ $format };
131 $format_list ->{ $format } = $code ;
136 return $format_list ->{ $format };
139 my $renderer_hash = {};
141 sub register_renderer
{
142 my ( $name, $code ) = @_ ;
144 die "renderer ' $name ' already registered \n "
145 if $renderer_hash ->{ $name };
147 $renderer_hash ->{ $name } = $code ;
152 return $renderer_hash ->{ $name };
155 # register some common type for pve
157 register_format
( 'string' , sub {}); # allow format => 'string-list'
159 register_format
( 'urlencoded' , \
& pve_verify_urlencoded
);
160 sub pve_verify_urlencoded
{
161 my ( $text, $noerr ) = @_ ;
162 if ( $text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/ ) {
163 return undef if $noerr ;
164 die "invalid urlencoded string: $text\n " ;
169 register_format
( 'pve-configid' , \
& pve_verify_configid
);
170 sub pve_verify_configid
{
171 my ( $id, $noerr ) = @_ ;
173 if ( $id !~ m/^[a-z][a-z0-9_-]+$/i ) {
174 return undef if $noerr ;
175 die "invalid configuration ID ' $id ' \n " ;
180 PVE
:: JSONSchema
:: register_format
( 'pve-storage-id' , \
& parse_storage_id
);
181 sub parse_storage_id
{
182 my ( $storeid, $noerr ) = @_ ;
184 return parse_id
( $storeid, 'storage' , $noerr );
187 PVE
:: JSONSchema
:: register_format
( 'acme-plugin-id' , \
& parse_acme_plugin_id
);
188 sub parse_acme_plugin_id
{
189 my ( $pluginid, $noerr ) = @_ ;
191 return parse_id
( $pluginid, 'ACME plugin' , $noerr );
195 my ( $id, $type, $noerr ) = @_ ;
197 if ( $id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
198 return undef if $noerr ;
199 die " $type ID ' $id ' contains illegal characters \n " ;
204 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
205 sub pve_verify_vmid
{
206 my ( $vmid, $noerr ) = @_ ;
208 if ( $vmid !~ m/^[1-9][0-9]{2,8}$/ ) {
209 return undef if $noerr ;
210 die "value does not look like a valid VM ID \n " ;
215 register_format
( 'pve-node' , \
& pve_verify_node_name
);
216 sub pve_verify_node_name
{
217 my ( $node, $noerr ) = @_ ;
219 if ( $node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/ ) {
220 return undef if $noerr ;
221 die "value does not look like a valid node name \n " ;
227 my ( $idmap, $idformat ) = @_ ;
229 return undef if ! $idmap ;
233 foreach my $entry ( PVE
:: Tools
:: split_list
( $idmap )) {
235 $map ->{ identity
} = 1 ;
236 } elsif ( $entry =~ m/^([^:]+):([^:]+)$/ ) {
237 my ( $source, $target ) = ( $1, $2 );
239 check_format
( $idformat, $source, '' );
240 check_format
( $idformat, $target, '' );
242 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
244 die "duplicate mapping for source ' $source ' \n "
245 if exists $map ->{ entries
}->{ $source };
247 $map ->{ entries
}->{ $source } = $target ;
250 check_format
( $idformat, $entry );
252 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
254 die "default target ID can only be provided once \n "
255 if exists $map ->{ default };
257 $map ->{ default } = $entry ;
261 die "identity mapping cannot be combined with other mappings \n "
262 if $map ->{ identity
} && ( $map ->{ default } || exists $map ->{ entries
});
267 register_format
( 'storagepair' , \
& verify_storagepair
);
268 sub verify_storagepair
{
269 my ( $storagepair, $noerr ) = @_ ;
271 # note: this only checks a single list entry
272 # when using a storagepair-list map, you need to pass the full
273 # parameter to parse_idmap
274 eval { parse_idmap
( $storagepair, 'pve-storage-id' ) };
276 return undef if $noerr ;
283 register_format
( 'mac-addr' , \
& pve_verify_mac_addr
);
284 sub pve_verify_mac_addr
{
285 my ( $mac_addr, $noerr ) = @_ ;
287 # don't allow I/G bit to be set, most of the time it breaks things, see:
288 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
289 if ( $mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i ) {
290 return undef if $noerr ;
291 die "value does not look like a valid unicast MAC address \n " ;
296 register_standard_option
( 'mac-addr' , {
298 description
=> 'Unicast MAC address.' ,
299 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.' ,
300 format_description
=> "XX:XX:XX:XX:XX:XX" ,
302 format
=> 'mac-addr' ,
305 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
306 sub pve_verify_ipv4
{
307 my ( $ipv4, $noerr ) = @_ ;
309 if ( $ipv4 !~ m/^(?:$IPV4RE)$/ ) {
310 return undef if $noerr ;
311 die "value does not look like a valid IPv4 address \n " ;
316 register_format
( 'ipv6' , \
& pve_verify_ipv6
);
317 sub pve_verify_ipv6
{
318 my ( $ipv6, $noerr ) = @_ ;
320 if ( $ipv6 !~ m/^(?:$IPV6RE)$/ ) {
321 return undef if $noerr ;
322 die "value does not look like a valid IPv6 address \n " ;
327 register_format
( 'ip' , \
& pve_verify_ip
);
329 my ( $ip, $noerr ) = @_ ;
331 if ( $ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/ ) {
332 return undef if $noerr ;
333 die "value does not look like a valid IP address \n " ;
338 PVE
:: JSONSchema
:: register_format
( 'ldap-simple-attr' , \
& verify_ldap_simple_attr
);
339 sub verify_ldap_simple_attr
{
340 my ( $attr, $noerr ) = @_ ;
342 if ( $attr =~ m/^[a-zA-Z0-9]+$/ ) {
346 die "value ' $attr ' does not look like a simple ldap attribute name \n " if ! $noerr ;
351 my $ipv4_mask_hash = {
369 '255.255.128.0' => 17 ,
370 '255.255.192.0' => 18 ,
371 '255.255.224.0' => 19 ,
372 '255.255.240.0' => 20 ,
373 '255.255.248.0' => 21 ,
374 '255.255.252.0' => 22 ,
375 '255.255.254.0' => 23 ,
376 '255.255.255.0' => 24 ,
377 '255.255.255.128' => 25 ,
378 '255.255.255.192' => 26 ,
379 '255.255.255.224' => 27 ,
380 '255.255.255.240' => 28 ,
381 '255.255.255.248' => 29 ,
382 '255.255.255.252' => 30 ,
383 '255.255.255.254' => 31 ,
384 '255.255.255.255' => 32 ,
387 sub get_netmask_bits
{
389 return $ipv4_mask_hash ->{ $mask };
392 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
393 sub pve_verify_ipv4mask
{
394 my ( $mask, $noerr ) = @_ ;
396 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
397 return undef if $noerr ;
398 die "value does not look like a valid IP netmask \n " ;
403 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
404 sub pve_verify_cidrv6
{
405 my ( $cidr, $noerr ) = @_ ;
407 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
411 return undef if $noerr ;
412 die "value does not look like a valid IPv6 CIDR network \n " ;
415 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
416 sub pve_verify_cidrv4
{
417 my ( $cidr, $noerr ) = @_ ;
419 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
423 return undef if $noerr ;
424 die "value does not look like a valid IPv4 CIDR network \n " ;
427 register_format
( 'CIDR' , \
& pve_verify_cidr
);
428 sub pve_verify_cidr
{
429 my ( $cidr, $noerr ) = @_ ;
431 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
432 pve_verify_cidrv6
( $cidr, 1 )))
434 return undef if $noerr ;
435 die "value does not look like a valid CIDR network \n " ;
441 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
442 sub pve_verify_ipv4_config
{
443 my ( $config, $noerr ) = @_ ;
445 return $config if $config =~ /^(?:dhcp|manual)$/ ||
446 pve_verify_cidrv4
( $config, 1 );
447 return undef if $noerr ;
448 die "value does not look like a valid ipv4 network configuration \n " ;
451 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
452 sub pve_verify_ipv6_config
{
453 my ( $config, $noerr ) = @_ ;
455 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
456 pve_verify_cidrv6
( $config, 1 );
457 return undef if $noerr ;
458 die "value does not look like a valid ipv6 network configuration \n " ;
461 register_format
( 'email' , \
& pve_verify_email
);
462 sub pve_verify_email
{
463 my ( $email, $noerr ) = @_ ;
465 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
466 return undef if $noerr ;
467 die "value does not look like a valid email address \n " ;
472 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
473 sub pve_verify_dns_name
{
474 my ( $name, $noerr ) = @_ ;
476 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
478 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
479 return undef if $noerr ;
480 die "value does not look like a valid DNS name \n " ;
485 register_format
( 'timezone' , \
& pve_verify_timezone
);
486 sub pve_verify_timezone
{
487 my ( $timezone, $noerr ) = @_ ;
489 return $timezone if $timezone eq 'UTC' ;
491 open ( my $fh, "<" , "/usr/share/zoneinfo/zone.tab" );
492 while ( my $line = < $fh >) {
493 next if $line =~ /^\s*#/ ;
495 my $zone = ( split /\t/ , $line )[ 2 ];
496 return $timezone if $timezone eq $zone ; # found
500 return undef if $noerr ;
501 die "invalid time zone ' $timezone ' \n " ;
504 # network interface name
505 register_format
( 'pve-iface' , \
& pve_verify_iface
);
506 sub pve_verify_iface
{
507 my ( $id, $noerr ) = @_ ;
509 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
510 return undef if $noerr ;
511 die "invalid network interface name ' $id ' \n " ;
516 # general addresses by name or IP
517 register_format
( 'address' , \
& pve_verify_address
);
518 sub pve_verify_address
{
519 my ( $addr, $noerr ) = @_ ;
521 if (!( pve_verify_ip
( $addr, 1 ) ||
522 pve_verify_dns_name
( $addr, 1 )))
524 return undef if $noerr ;
525 die "value does not look like a valid address: $addr\n " ;
530 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
531 sub pve_verify_disk_size
{
532 my ( $size, $noerr ) = @_ ;
533 if (! defined ( parse_size
( $size ))) {
534 return undef if $noerr ;
535 die "value does not look like a valid disk size: $size\n " ;
540 register_standard_option
( 'spice-proxy' , {
541 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)." ,
542 type
=> 'string' , format
=> 'address' ,
545 register_standard_option
( 'remote-viewer-config' , {
546 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
547 additionalProperties
=> 1 ,
549 type
=> { type
=> 'string' },
550 password
=> { type
=> 'string' },
551 proxy
=> { type
=> 'string' },
552 host
=> { type
=> 'string' },
553 'tls-port' => { type
=> 'integer' },
557 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
558 sub pve_verify_startup_order
{
559 my ( $value, $noerr ) = @_ ;
561 return $value if pve_parse_startup_order
( $value );
563 return undef if $noerr ;
565 die "unable to parse startup options \n " ;
570 type
=> 'number' , minimum
=> '0' ,
571 format_description
=> 'LIMIT' ,
574 my $bwlimit_format = {
577 description
=> 'default bandwidth limit in KiB/s' ,
581 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
585 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
589 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
593 description
=> 'bandwidth limit in KiB/s for moving disks' ,
596 register_format
( 'bwlimit' , $bwlimit_format );
597 register_standard_option
( 'bwlimit' , {
598 description
=> "Set bandwidth/io limits various operations." ,
601 format
=> $bwlimit_format,
604 # used for pve-tag-list in e.g., guest configs
605 register_format
( 'pve-tag' , \
& pve_verify_tag
);
607 my ( $value, $noerr ) = @_ ;
609 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i ;
611 return undef if $noerr ;
613 die "invalid characters in tag \n " ;
616 sub pve_parse_startup_order
{
619 return undef if ! $value ;
623 foreach my $p ( split ( /,/ , $value )) {
624 next if $p =~ m/^\s*$/ ;
626 if ( $p =~ m/^(order=)?(\d+)$/ ) {
628 } elsif ( $p =~ m/^up=(\d+)$/ ) {
630 } elsif ( $p =~ m/^down=(\d+)$/ ) {
640 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
641 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." ,
643 type
=> 'string' , format
=> 'pve-startup-order' ,
644 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
647 register_format
( 'pve-tfa-secret' , \
& pve_verify_tfa_secret
);
648 sub pve_verify_tfa_secret
{
649 my ( $key, $noerr ) = @_ ;
651 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
652 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
653 # format to support arbitrary lengths properly:
654 if ( $key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
655 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
656 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/ ) # and the old pattern copy&pasted
661 return undef if $noerr ;
663 die "unable to decode TFA secret \n " ;
667 my ( $format, $value, $path ) = @_ ;
669 return parse_property_string
( $format, $value, $path ) if ref ( $format ) eq 'HASH' ;
670 return if $format eq 'regex' ;
672 if ( $format =~ m/^(.*)-a?list$/ ) {
674 my $code = $format_list ->{ $1 };
676 die "undefined format ' $format ' \n " if ! $code ;
678 # Note: we allow empty lists
679 foreach my $v ( split_list
( $value )) {
683 } elsif ( $format =~ m/^(.*)-opt$/ ) {
685 my $code = $format_list ->{ $1 };
687 die "undefined format ' $format ' \n " if ! $code ;
689 return if ! $value ; # allow empty string
695 my $code = $format_list ->{ $format };
697 die "undefined format ' $format ' \n " if ! $code ;
699 return parse_property_string
( $code, $value, $path ) if ref ( $code ) eq 'HASH' ;
707 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
708 my ( $size, $unit ) = ( $1, $3 );
711 $size = $size * 1024 ;
712 } elsif ( $unit eq 'M' ) {
713 $size = $size * 1024 * 1024 ;
714 } elsif ( $unit eq 'G' ) {
715 $size = $size * 1024 * 1024 * 1024 ;
716 } elsif ( $unit eq 'T' ) {
717 $size = $size * 1024 * 1024 * 1024 * 1024 ;
728 my $kb = int ( $size/1024 );
729 return $size if $kb*1024 != $size ;
731 my $mb = int ( $kb/1024 );
732 return "${kb}K" if $mb*1024 != $kb ;
734 my $gb = int ( $mb/1024 );
735 return "${mb}M" if $gb*1024 != $mb ;
737 my $tb = int ( $gb/1024 );
738 return "${gb}G" if $tb*1024 != $gb ;
745 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
746 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
750 sub parse_property_string
{
751 my ( $format, $data, $path, $additional_properties ) = @_ ;
753 # In property strings we default to not allowing additional properties
754 $additional_properties = 0 if ! defined ( $additional_properties );
756 # Support named formats here, too:
758 if ( my $desc = $format_list ->{ $format }) {
761 die "unknown format: $format\n " ;
763 } elsif ( ref ( $format ) ne 'HASH' ) {
764 die "unexpected format value of type " . ref ( $format ). " \n " ;
770 foreach my $part ( split ( /,/ , $data )) {
771 next if $part =~ /^\s*$/ ;
773 if ( $part =~ /^([^=]+)=(.+)$/ ) {
774 my ( $k, $v ) = ( $1, $2 );
775 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
776 my $schema = $format ->{ $k };
777 if ( my $alias = $schema ->{ alias
}) {
778 if ( my $key_alias = $schema ->{ keyAlias
}) {
779 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
780 $res ->{ $key_alias } = $k ;
783 $schema = $format ->{ $k };
786 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
787 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
788 $v = parse_boolean
( $v ) // $v ;
791 } elsif ( $part !~ /=/ ) {
792 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
793 foreach my $key ( keys %$format ) {
794 if ( $format ->{ $key }->{ default_key
}) {
796 if (! $res ->{ $default_key }) {
797 $res ->{ $default_key } = $part ;
800 die "duplicate key in comma-separated list property: $default_key\n " ;
803 die "value without key, but schema does not define a default key \n " if ! $default_key ;
805 die "missing key in comma-separated list property \n " ;
810 check_object
( $path, $format, $res, $additional_properties, $errors );
811 if ( scalar ( %$errors )) {
812 raise
"format error \n " , errors
=> $errors ;
819 my ( $errors, $path, $msg ) = @_ ;
821 $path = '_root' if ! $path ;
823 if ( $errors ->{ $path }) {
824 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
826 $errors ->{ $path } = $msg ;
833 # see 'man perlretut'
834 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
840 return $value =~ m/^[+-]?\d+$/ ;
844 my ( $path, $type, $value, $errors ) = @_ ;
848 if (! defined ( $value )) {
849 return 1 if $type eq 'null' ;
853 if ( my $tt = ref ( $type )) {
854 if ( $tt eq 'ARRAY' ) {
855 foreach my $t ( @$type ) {
857 check_type
( $path, $t, $value, $tmperr );
858 return 1 if ! scalar ( %$tmperr );
860 my $ttext = join ( '|' , @$type );
861 add_error
( $errors, $path, "type check (' $ttext ') failed" );
863 } elsif ( $tt eq 'HASH' ) {
865 check_prop
( $value, $type, $path, $tmperr );
866 return 1 if ! scalar ( %$tmperr );
867 add_error
( $errors, $path, "type check failed" );
870 die "internal error - got reference type ' $tt '" ;
875 return 1 if $type eq 'any' ;
877 if ( $type eq 'null' ) {
878 if ( defined ( $value )) {
879 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
885 my $vt = ref ( $value );
887 if ( $type eq 'array' ) {
888 if (! $vt || $vt ne 'ARRAY' ) {
889 add_error
( $errors, $path, "type check (' $type ') failed" );
893 } elsif ( $type eq 'object' ) {
894 if (! $vt || $vt ne 'HASH' ) {
895 add_error
( $errors, $path, "type check (' $type ') failed" );
899 } elsif ( $type eq 'coderef' ) {
900 if (! $vt || $vt ne 'CODE' ) {
901 add_error
( $errors, $path, "type check (' $type ') failed" );
905 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
906 # qr// regexes can be used as strings and make sense for format=regex
910 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
913 if ( $type eq 'string' ) {
914 return 1 ; # nothing to check ?
915 } elsif ( $type eq 'boolean' ) {
916 #if ($value =~ m/^(1|true|yes|on)$/i) {
919 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
920 } elsif ( $value eq '0' ) {
921 return 1 ; # return success (not value)
923 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
926 } elsif ( $type eq 'integer' ) {
927 if (! is_integer
( $value )) {
928 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
932 } elsif ( $type eq 'number' ) {
933 if (! is_number
( $value )) {
934 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
939 return 1 ; # no need to verify unknown types
949 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
951 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
953 my $st = ref ( $schema );
954 if (! $st || $st ne 'HASH' ) {
955 add_error
( $errors, $path, "Invalid schema definition." );
959 my $vt = ref ( $value );
960 if (! $vt || $vt ne 'HASH' ) {
961 add_error
( $errors, $path, "an object is required" );
965 foreach my $k ( keys %$schema ) {
966 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
969 foreach my $k ( keys %$value ) {
971 my $newpath = $path ?
" $path . $k " : $k ;
973 if ( my $subschema = $schema ->{ $k }) {
974 if ( my $requires = $subschema ->{ requires
}) {
975 if ( ref ( $requires )) {
976 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
977 check_prop
( $value, $requires, $path, $errors );
978 } elsif (! defined ( $value ->{ $requires })) {
979 add_error
( $errors, $path ?
" $path . $requires " : $requires,
980 "missing property - ' $newpath ' requires this property" );
984 next ; # value is already checked above
987 if ( defined ( $additional_properties ) && ! $additional_properties ) {
988 add_error
( $errors, $newpath, "property is not defined in schema " .
989 "and the schema does not allow additional properties" );
992 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
993 if ref ( $additional_properties );
997 sub check_object_warn
{
998 my ( $path, $schema, $value, $additional_properties ) = @_ ;
1000 check_object
( $path, $schema, $value, $additional_properties, $errors );
1001 if ( scalar ( %$errors )) {
1002 foreach my $k ( keys %$errors ) {
1003 warn "parse error: $k : $errors ->{ $k } \n " ;
1011 my ( $value, $schema, $path, $errors ) = @_ ;
1013 die "internal error - no schema" if ! $schema ;
1014 die "internal error" if ! $errors ;
1016 #print "check_prop $path\n" if $value;
1018 my $st = ref ( $schema );
1019 if (! $st || $st ne 'HASH' ) {
1020 add_error
( $errors, $path, "Invalid schema definition." );
1024 # if it extends another schema, it must pass that schema as well
1025 if ( $schema ->{ extends
}) {
1026 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
1029 if (! defined ( $value )) {
1030 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
1031 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
1032 add_error
( $errors, $path, "property is missing and it is not optional" );
1037 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
1039 if ( $schema ->{ disallow
}) {
1041 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
1042 add_error
( $errors, $path, "disallowed value was matched" );
1047 if ( my $vt = ref ( $value )) {
1049 if ( $vt eq 'ARRAY' ) {
1050 if ( $schema ->{ items
}) {
1051 my $it = ref ( $schema ->{ items
});
1052 if ( $it && $it eq 'ARRAY' ) {
1053 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1054 die "not implemented" ;
1057 foreach my $el ( @$value ) {
1058 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
1064 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
1065 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
1066 $value, $schema ->{ additionalProperties
}, $errors );
1072 if ( my $format = $schema ->{ format
}) {
1073 eval { check_format
( $format, $value, $path ); };
1075 add_error
( $errors, $path, "invalid format - $@ " );
1080 if ( my $pattern = $schema ->{ pattern
}) {
1081 if ( $value !~ m/^$pattern$/ ) {
1082 add_error
( $errors, $path, "value does not match the regex pattern" );
1087 if ( defined ( my $max = $schema ->{ maxLength
})) {
1088 if ( length ( $value ) > $max ) {
1089 add_error
( $errors, $path, "value may only be $max characters long" );
1094 if ( defined ( my $min = $schema ->{ minLength
})) {
1095 if ( length ( $value ) < $min ) {
1096 add_error
( $errors, $path, "value must be at least $min characters long" );
1101 if ( is_number
( $value )) {
1102 if ( defined ( my $max = $schema ->{ maximum
})) {
1103 if ( $value > $max ) {
1104 add_error
( $errors, $path, "value must have a maximum value of $max " );
1109 if ( defined ( my $min = $schema ->{ minimum
})) {
1110 if ( $value < $min ) {
1111 add_error
( $errors, $path, "value must have a minimum value of $min " );
1117 if ( my $ea = $schema ->{ enum
}) {
1120 foreach my $ev ( @$ea ) {
1121 if ( $ev eq $value ) {
1127 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
1128 join ( ", " , @$ea ) . "'" );
1135 my ( $instance, $schema, $errmsg ) = @_ ;
1138 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1140 # todo: cycle detection is only needed for debugging, I guess
1141 # we can disable that in the final release
1142 # todo: is there a better/faster way to detect cycles?
1144 find_cycle
( $instance, sub { $cycles = 1 });
1146 add_error
( $errors, undef , "data structure contains recursive cycles" );
1148 check_prop
( $instance, $schema, '' , $errors );
1151 if ( scalar ( %$errors )) {
1152 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1158 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1159 my $default_schema_noref = {
1160 description
=> "This is the JSON Schema for JSON Schemas." ,
1161 type
=> [ "object" ],
1162 additionalProperties
=> 0 ,
1165 type
=> [ "string" , "array" ],
1166 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1171 enum
=> $schema_valid_types,
1173 enum
=> $schema_valid_types,
1177 description
=> "This indicates that the instance property in the instance object is not required." ,
1183 description
=> "This is a definition for the properties of an object value" ,
1189 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1193 additionalProperties
=> {
1194 type
=> [ "boolean" , "object" ],
1195 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1202 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1207 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1211 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1218 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1224 description
=> "A text representation of the type (used to generate documentation)." ,
1229 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." ,
1236 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1241 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)." ,
1243 verbose_description
=> {
1246 description
=> "This provides a more verbose description." ,
1248 format_description
=> {
1251 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1256 description
=> "This provides the title of the property" ,
1261 description
=> "This is used to provide rendering hints to format cli command output." ,
1264 type
=> [ "string" , "object" ],
1266 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1269 type
=> [ "string" , "object" ],
1271 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" ,
1276 description
=> "Whether this is the default key in a comma separated list property string." ,
1281 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." ,
1286 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1287 requires
=> 'alias' ,
1292 description
=> "This indicates the default for the instance property."
1296 description
=> "Bash completion function. This function should return a list of possible values." ,
1302 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." ,
1307 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1310 # this is from hyper schema
1313 description
=> "This defines the link relations of the instance objects" ,
1320 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" ,
1324 description
=> "This is the name of the link relation" ,
1330 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1339 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1345 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1347 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1348 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1350 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1351 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1353 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1354 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1356 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1357 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1359 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1360 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1362 my $method_schema = {
1364 additionalProperties
=> 0 ,
1367 description
=> "This a description of the method" ,
1372 description
=> "This indicates the name of the function to call." ,
1375 additionalProperties
=> 1 ,
1390 description
=> "The HTTP method name." ,
1391 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1396 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1401 description
=> "Method is available for clients authenticated using an API token." ,
1407 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1412 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1415 proxyto_callback
=> {
1417 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1422 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1424 additionalProperties
=> 0 ,
1427 description
=> "Describe access permissions." ,
1431 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1433 enum
=> [ 'all' , 'world' ],
1437 description
=> "Array of permission checks (prefix notation)." ,
1444 description
=> "Used internally" ,
1448 description
=> "Used internally" ,
1453 description
=> "path for URL matching (uri template)" ,
1455 fragmentDelimiter
=> {
1457 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." ,
1462 description
=> "JSON Schema for parameters." ,
1467 description
=> "JSON Schema for return value." ,
1472 description
=> "method implementation (code reference)" ,
1477 description
=> "Delegate call to this class (perl class string)." ,
1480 additionalProperties
=> 0 ,
1486 fragmentDelimiter
=> { optional
=> 1 }
1494 sub validate_schema
{
1497 my $errmsg = "internal error - unable to verify schema \n " ;
1498 validate
( $schema, $default_schema, $errmsg );
1501 sub validate_method_info
{
1504 my $errmsg = "internal error - unable to verify method info \n " ;
1505 validate
( $info, $method_schema, $errmsg );
1507 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1508 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1511 # run a self test on load
1512 # make sure we can verify the default schema
1513 validate_schema
( $default_schema_noref );
1514 validate_schema
( $method_schema );
1516 # and now some utility methods (used by pve api)
1517 sub method_get_child_link
{
1520 return undef if ! $info ;
1522 my $schema = $info ->{ returns
};
1523 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1525 my $links = $schema ->{ links
};
1526 return undef if ! $links ;
1529 foreach my $lnk ( @$links ) {
1530 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1539 # a way to parse command line parameters, using a
1540 # schema to configure Getopt::Long
1542 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1544 if (! $schema || ! $schema ->{ properties
}) {
1545 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1546 if scalar ( @$args ) != 0 ;
1551 if ( $arg_param && ! ref ( $arg_param )) {
1552 my $pd = $schema ->{ properties
}->{ $arg_param };
1553 die "expected list format $pd ->{format}"
1554 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1555 $list_param = $arg_param ;
1558 my @interactive = ();
1560 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1561 my $pd = $schema ->{ properties
}->{ $prop };
1562 next if $list_param && $prop eq $list_param ;
1563 next if defined ( $fixed_param ->{ $prop });
1565 my $mapping = $param_mapping_hash ->{ $prop };
1566 if ( $mapping && $mapping ->{ interactive
}) {
1567 # interactive parameters such as passwords: make the argument
1568 # optional and call the mapping function afterwards.
1569 push @getopt, " $prop :s" ;
1570 push @interactive, [ $prop, $mapping ->{ func
}];
1571 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1572 push @getopt, " $prop :s" ;
1574 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1575 push @getopt, " $prop =s@" ;
1577 push @getopt, " $prop =s" ;
1582 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1585 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1586 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1590 $opts ->{ $list_param } = $args ;
1592 } elsif ( ref ( $arg_param )) {
1593 foreach my $arg_name ( @$arg_param ) {
1594 if ( $opts ->{ 'extra-args' }) {
1595 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1597 if ( $arg_name eq 'extra-args' ) {
1598 $opts ->{ 'extra-args' } = $args ;
1602 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1603 $opts ->{ $arg_name } = shift @$args ;
1605 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1607 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1608 if scalar ( @$args ) != 0 ;
1611 if ( ref ( $arg_param )) {
1612 foreach my $arg_name ( @$arg_param ) {
1613 if ( $arg_name eq 'extra-args' ) {
1614 $opts ->{ 'extra-args' } = [];
1616 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1622 foreach my $entry ( @interactive ) {
1623 my ( $opt, $func ) = @$entry ;
1624 my $pd = $schema ->{ properties
}->{ $opt };
1625 my $value = $opts ->{ $opt };
1626 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1627 $opts ->{ $opt } = $func ->( $value );
1631 # decode after Getopt as we are not sure how well it handles unicode
1632 foreach my $p ( keys %$opts ) {
1633 if (! ref ( $opts ->{ $p })) {
1634 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1635 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1637 foreach my $v (@{ $opts ->{ $p }}) {
1638 push @$tmp, decode
( 'locale' , $v );
1641 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1642 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1644 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1648 foreach my $p ( keys %$opts ) {
1649 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1650 if ( $pd ->{ type
} eq 'boolean' ) {
1651 if ( $opts ->{ $p } eq '' ) {
1653 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1654 $opts ->{ $p } = $bool ;
1656 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1658 } elsif ( $pd ->{ format
}) {
1660 if ( $pd ->{ format
} =~ m/-list/ ) {
1661 # allow --vmid 100 --vmid 101 and --vmid 100,101
1662 # allow --dow mon --dow fri and --dow mon,fri
1663 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1664 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1665 # we encode array as \0 separated strings
1666 # Note: CGI.pm also use this encoding
1667 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1668 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1670 # st that split_list knows it is \0 terminated
1671 my $v = $opts ->{ $p }->[ 0 ];
1672 $opts ->{ $p } = " $v\0 " ;
1679 foreach my $p ( keys %$fixed_param ) {
1680 $opts ->{ $p } = $fixed_param ->{ $p };
1686 # A way to parse configuration data by giving a json schema
1688 my ( $schema, $filename, $raw ) = @_ ;
1690 # do fast check (avoid validate_schema($schema))
1691 die "got strange schema" if ! $schema ->{ type
} ||
1692 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1696 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1699 next if $line =~ /^#/ ;
1701 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1704 if ( $schema ->{ properties
}->{ $key } &&
1705 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1707 $value = parse_boolean
( $value ) // $value ;
1709 $cfg ->{ $key } = $value ;
1711 warn "ignore config line: $line\n "
1716 check_prop
( $cfg, $schema, '' , $errors );
1718 foreach my $k ( keys %$errors ) {
1719 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1726 # generate simple key/value file
1728 my ( $schema, $filename, $cfg ) = @_ ;
1730 # do fast check (avoid validate_schema($schema))
1731 die "got strange schema" if ! $schema ->{ type
} ||
1732 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1734 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1738 foreach my $k ( sort keys %$cfg ) {
1739 $data .= " $k : $cfg ->{ $k } \n " ;
1745 # helpers used to generate our manual pages
1747 my $find_schema_default_key = sub {
1751 my $keyAliasProps = {};
1753 foreach my $key ( keys %$format ) {
1754 my $phash = $format ->{ $key };
1755 if ( $phash ->{ default_key
}) {
1756 die "multiple default keys in schema ( $default_key, $key ) \n "
1757 if defined ( $default_key );
1758 die "default key ' $key ' is an alias - this is not allowed \n "
1759 if defined ( $phash ->{ alias
});
1760 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1761 if $phash ->{ keyAlias
};
1762 $default_key = $key ;
1764 my $key_alias = $phash ->{ keyAlias
};
1765 die "found keyAlias without 'alias definition for ' $key ' \n "
1766 if $key_alias && ! $phash ->{ alias
};
1768 if ( $phash ->{ alias
} && $key_alias ) {
1769 die "inconsistent keyAlias ' $key_alias ' definition"
1770 if defined ( $keyAliasProps ->{ $key_alias }) &&
1771 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1772 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1776 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1779 sub generate_typetext
{
1780 my ( $format, $list_enums ) = @_ ;
1782 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1787 my $add_option_string = sub {
1788 my ( $text, $optional ) = @_ ;
1794 $text = "[ $text ]" if $optional ;
1799 my $format_key_value = sub {
1800 my ( $key, $phash ) = @_ ;
1802 die "internal error" if defined ( $phash ->{ alias
});
1808 if ( my $desc = $phash ->{ format_description
}) {
1809 $typetext .= "< $desc >" ;
1810 } elsif ( my $text = $phash ->{ typetext
}) {
1812 } elsif ( my $enum = $phash ->{ enum
}) {
1813 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1814 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1816 $typetext .= '<enum>' ;
1818 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1819 $typetext .= '<1|0>' ;
1820 } elsif ( $phash ->{ type
} eq 'integer' ) {
1821 $typetext .= '<integer>' ;
1822 } elsif ( $phash ->{ type
} eq 'number' ) {
1823 $typetext .= '<number>' ;
1825 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1828 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1829 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1831 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1837 my $cond_add_key = sub {
1840 return if $done ->{ $key }; # avoid duplicates
1844 my $phash = $format ->{ $key };
1846 return if ! $phash ; # should not happen
1848 return if $phash ->{ alias
};
1850 & $format_key_value ( $key, $phash );
1854 & $cond_add_key ( $default_key ) if defined ( $default_key );
1856 # add required keys first
1857 foreach my $key ( sort keys %$format ) {
1858 my $phash = $format ->{ $key };
1859 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1863 foreach my $key ( sort keys %$format ) {
1864 & $cond_add_key ( $key );
1867 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1868 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1874 sub print_property_string
{
1875 my ( $data, $format, $skip, $path ) = @_ ;
1877 if ( ref ( $format ) ne 'HASH' ) {
1878 my $schema = get_format
( $format );
1879 die "not a valid format: $format\n " if ! $schema ;
1884 check_object
( $path, $format, $data, undef , $errors );
1885 if ( scalar ( %$errors )) {
1886 raise
"format error" , errors
=> $errors ;
1889 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1894 my $add_option_string = sub {
1897 $res .= ',' if $add_sep ;
1902 my $format_value = sub {
1903 my ( $key, $value, $format ) = @_ ;
1905 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1906 return format_size
( $value );
1908 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1913 my $done = { map { $_ => 1 } @$skip };
1915 my $cond_add_key = sub {
1916 my ( $key, $isdefault ) = @_ ;
1918 return if $done ->{ $key }; # avoid duplicates
1922 my $value = $data ->{ $key };
1924 return if ! defined ( $value );
1926 my $phash = $format ->{ $key };
1928 # try to combine values if we have key aliases
1929 if ( my $combine = $keyAliasProps ->{ $key }) {
1930 if ( defined ( my $combine_value = $data ->{ $combine })) {
1931 my $combine_format = $format ->{ $combine }->{ format
};
1932 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1933 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1934 & $add_option_string ( "${value_str}=${combine_str}" );
1935 $done ->{ $combine } = 1 ;
1940 if ( $phash && $phash ->{ alias
}) {
1941 $phash = $format ->{ $phash ->{ alias
}};
1944 die "invalid key ' $key ' \n " if ! $phash ;
1945 die "internal error" if defined ( $phash ->{ alias
});
1947 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1949 & $add_option_string ( $value_str );
1951 & $add_option_string ( " $key =${value_str}" );
1955 # add default key first
1956 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1958 # add required keys first
1959 foreach my $key ( sort keys %$data ) {
1960 my $phash = $format ->{ $key };
1961 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1965 foreach my $key ( sort keys %$data ) {
1966 & $cond_add_key ( $key );
1972 sub schema_get_type_text
{
1973 my ( $phash, $style ) = @_ ;
1975 my $type = $phash ->{ type
} || 'string' ;
1977 if ( $phash ->{ typetext
}) {
1978 return $phash ->{ typetext
};
1979 } elsif ( $phash ->{ format_description
}) {
1980 return "< $phash ->{format_description}>" ;
1981 } elsif ( $phash ->{ enum
}) {
1982 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
1983 } elsif ( $phash ->{ pattern
}) {
1984 return $phash ->{ pattern
};
1985 } elsif ( $type eq 'integer' || $type eq 'number' ) {
1986 # NOTE: always access values as number (avoid converion to string)
1987 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
1988 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
1989 ( $phash ->{ maximum
} + 0 ) . ")" ;
1990 } elsif ( defined ( $phash ->{ minimum
})) {
1991 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
1992 } elsif ( defined ( $phash ->{ maximum
})) {
1993 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
1995 } elsif ( $type eq 'string' ) {
1996 if ( my $format = $phash ->{ format
}) {
1997 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
1998 if ( ref ( $format ) eq 'HASH' ) {
2000 $list_enums = 1 if $style && $style eq 'config-sub' ;
2001 return generate_typetext
( $format, $list_enums );