]>
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 PVE
:: JSONSchema
:: check_format
( $idformat, $source, '' );
239 PVE
:: JSONSchema
:: check_format
( $idformat, $target, '' );
241 die "entry ' $entry ' contains invalid ID - $@\n "
244 die "duplicate mapping for source ' $source ' \n "
245 if $map ->{ entries
}->{ $source };
247 $map ->{ entries
}->{ $source } = $target ;
250 PVE
:: JSONSchema
:: check_format
( $idformat, $entry );
253 die "entry ' $entry ' contains invalid ID - $@\n "
256 die "default target ID can only be provided once \n "
259 $map ->{ default } = $entry ;
263 die "identity mapping cannot be combined with other mappings \n "
264 if $map ->{ identity
} && ( $map ->{ default } || $map ->{ entries
});
269 register_format
( 'storagepair' , \
& verify_storagepair
);
270 sub verify_storagepair
{
271 my ( $storagepair, $noerr ) = @_ ;
273 # note: this only checks a single list entry
274 # when using a storagepair-list map, you need to pass the full
275 # parameter to parse_idmap
276 eval { parse_idmap
( $storagepair, 'pve-storage-id' ) };
278 return undef if $noerr ;
285 register_format
( 'mac-addr' , \
& pve_verify_mac_addr
);
286 sub pve_verify_mac_addr
{
287 my ( $mac_addr, $noerr ) = @_ ;
289 # don't allow I/G bit to be set, most of the time it breaks things, see:
290 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
291 if ( $mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i ) {
292 return undef if $noerr ;
293 die "value does not look like a valid unicast MAC address \n " ;
298 register_standard_option
( 'mac-addr' , {
300 description
=> 'Unicast MAC address.' ,
301 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.' ,
302 format_description
=> "XX:XX:XX:XX:XX:XX" ,
304 format
=> 'mac-addr' ,
307 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
308 sub pve_verify_ipv4
{
309 my ( $ipv4, $noerr ) = @_ ;
311 if ( $ipv4 !~ m/^(?:$IPV4RE)$/ ) {
312 return undef if $noerr ;
313 die "value does not look like a valid IPv4 address \n " ;
318 register_format
( 'ipv6' , \
& pve_verify_ipv6
);
319 sub pve_verify_ipv6
{
320 my ( $ipv6, $noerr ) = @_ ;
322 if ( $ipv6 !~ m/^(?:$IPV6RE)$/ ) {
323 return undef if $noerr ;
324 die "value does not look like a valid IPv6 address \n " ;
329 register_format
( 'ip' , \
& pve_verify_ip
);
331 my ( $ip, $noerr ) = @_ ;
333 if ( $ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/ ) {
334 return undef if $noerr ;
335 die "value does not look like a valid IP address \n " ;
340 PVE
:: JSONSchema
:: register_format
( 'ldap-simple-attr' , \
& verify_ldap_simple_attr
);
341 sub verify_ldap_simple_attr
{
342 my ( $attr, $noerr ) = @_ ;
344 if ( $attr =~ m/^[a-zA-Z0-9]+$/ ) {
348 die "value ' $attr ' does not look like a simple ldap attribute name \n " if ! $noerr ;
353 my $ipv4_mask_hash = {
371 '255.255.128.0' => 17 ,
372 '255.255.192.0' => 18 ,
373 '255.255.224.0' => 19 ,
374 '255.255.240.0' => 20 ,
375 '255.255.248.0' => 21 ,
376 '255.255.252.0' => 22 ,
377 '255.255.254.0' => 23 ,
378 '255.255.255.0' => 24 ,
379 '255.255.255.128' => 25 ,
380 '255.255.255.192' => 26 ,
381 '255.255.255.224' => 27 ,
382 '255.255.255.240' => 28 ,
383 '255.255.255.248' => 29 ,
384 '255.255.255.252' => 30 ,
385 '255.255.255.254' => 31 ,
386 '255.255.255.255' => 32 ,
389 sub get_netmask_bits
{
391 return $ipv4_mask_hash ->{ $mask };
394 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
395 sub pve_verify_ipv4mask
{
396 my ( $mask, $noerr ) = @_ ;
398 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
399 return undef if $noerr ;
400 die "value does not look like a valid IP netmask \n " ;
405 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
406 sub pve_verify_cidrv6
{
407 my ( $cidr, $noerr ) = @_ ;
409 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
413 return undef if $noerr ;
414 die "value does not look like a valid IPv6 CIDR network \n " ;
417 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
418 sub pve_verify_cidrv4
{
419 my ( $cidr, $noerr ) = @_ ;
421 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
425 return undef if $noerr ;
426 die "value does not look like a valid IPv4 CIDR network \n " ;
429 register_format
( 'CIDR' , \
& pve_verify_cidr
);
430 sub pve_verify_cidr
{
431 my ( $cidr, $noerr ) = @_ ;
433 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
434 pve_verify_cidrv6
( $cidr, 1 )))
436 return undef if $noerr ;
437 die "value does not look like a valid CIDR network \n " ;
443 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
444 sub pve_verify_ipv4_config
{
445 my ( $config, $noerr ) = @_ ;
447 return $config if $config =~ /^(?:dhcp|manual)$/ ||
448 pve_verify_cidrv4
( $config, 1 );
449 return undef if $noerr ;
450 die "value does not look like a valid ipv4 network configuration \n " ;
453 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
454 sub pve_verify_ipv6_config
{
455 my ( $config, $noerr ) = @_ ;
457 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
458 pve_verify_cidrv6
( $config, 1 );
459 return undef if $noerr ;
460 die "value does not look like a valid ipv6 network configuration \n " ;
463 register_format
( 'email' , \
& pve_verify_email
);
464 sub pve_verify_email
{
465 my ( $email, $noerr ) = @_ ;
467 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
468 return undef if $noerr ;
469 die "value does not look like a valid email address \n " ;
474 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
475 sub pve_verify_dns_name
{
476 my ( $name, $noerr ) = @_ ;
478 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
480 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
481 return undef if $noerr ;
482 die "value does not look like a valid DNS name \n " ;
487 # network interface name
488 register_format
( 'pve-iface' , \
& pve_verify_iface
);
489 sub pve_verify_iface
{
490 my ( $id, $noerr ) = @_ ;
492 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
493 return undef if $noerr ;
494 die "invalid network interface name ' $id ' \n " ;
499 # general addresses by name or IP
500 register_format
( 'address' , \
& pve_verify_address
);
501 sub pve_verify_address
{
502 my ( $addr, $noerr ) = @_ ;
504 if (!( pve_verify_ip
( $addr, 1 ) ||
505 pve_verify_dns_name
( $addr, 1 )))
507 return undef if $noerr ;
508 die "value does not look like a valid address: $addr\n " ;
513 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
514 sub pve_verify_disk_size
{
515 my ( $size, $noerr ) = @_ ;
516 if (! defined ( parse_size
( $size ))) {
517 return undef if $noerr ;
518 die "value does not look like a valid disk size: $size\n " ;
523 register_standard_option
( 'spice-proxy' , {
524 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)." ,
525 type
=> 'string' , format
=> 'address' ,
528 register_standard_option
( 'remote-viewer-config' , {
529 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
530 additionalProperties
=> 1 ,
532 type
=> { type
=> 'string' },
533 password
=> { type
=> 'string' },
534 proxy
=> { type
=> 'string' },
535 host
=> { type
=> 'string' },
536 'tls-port' => { type
=> 'integer' },
540 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
541 sub pve_verify_startup_order
{
542 my ( $value, $noerr ) = @_ ;
544 return $value if pve_parse_startup_order
( $value );
546 return undef if $noerr ;
548 die "unable to parse startup options \n " ;
553 type
=> 'number' , minimum
=> '0' ,
554 format_description
=> 'LIMIT' ,
557 my $bwlimit_format = {
560 description
=> 'default bandwidth limit in KiB/s' ,
564 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
568 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
572 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
576 description
=> 'bandwidth limit in KiB/s for moving disks' ,
579 register_format
( 'bwlimit' , $bwlimit_format );
580 register_standard_option
( 'bwlimit' , {
581 description
=> "Set bandwidth/io limits various operations." ,
584 format
=> $bwlimit_format,
587 # used for pve-tag-list in e.g., guest configs
588 register_format
( 'pve-tag' , \
& pve_verify_tag
);
590 my ( $value, $noerr ) = @_ ;
592 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i ;
594 return undef if $noerr ;
596 die "invalid characters in tag \n " ;
599 sub pve_parse_startup_order
{
602 return undef if ! $value ;
606 foreach my $p ( split ( /,/ , $value )) {
607 next if $p =~ m/^\s*$/ ;
609 if ( $p =~ m/^(order=)?(\d+)$/ ) {
611 } elsif ( $p =~ m/^up=(\d+)$/ ) {
613 } elsif ( $p =~ m/^down=(\d+)$/ ) {
623 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
624 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." ,
626 type
=> 'string' , format
=> 'pve-startup-order' ,
627 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
630 register_format
( 'pve-tfa-secret' , \
& pve_verify_tfa_secret
);
631 sub pve_verify_tfa_secret
{
632 my ( $key, $noerr ) = @_ ;
634 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
635 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
636 # format to support arbitrary lengths properly:
637 if ( $key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
638 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
639 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/ ) # and the old pattern copy&pasted
644 return undef if $noerr ;
646 die "unable to decode TFA secret \n " ;
650 my ( $format, $value, $path ) = @_ ;
652 return parse_property_string
( $format, $value, $path ) if ref ( $format ) eq 'HASH' ;
653 return if $format eq 'regex' ;
655 if ( $format =~ m/^(.*)-a?list$/ ) {
657 my $code = $format_list ->{ $1 };
659 die "undefined format ' $format ' \n " if ! $code ;
661 # Note: we allow empty lists
662 foreach my $v ( split_list
( $value )) {
666 } elsif ( $format =~ m/^(.*)-opt$/ ) {
668 my $code = $format_list ->{ $1 };
670 die "undefined format ' $format ' \n " if ! $code ;
672 return if ! $value ; # allow empty string
678 my $code = $format_list ->{ $format };
680 die "undefined format ' $format ' \n " if ! $code ;
682 return parse_property_string
( $code, $value, $path ) if ref ( $code ) eq 'HASH' ;
690 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
691 my ( $size, $unit ) = ( $1, $3 );
694 $size = $size * 1024 ;
695 } elsif ( $unit eq 'M' ) {
696 $size = $size * 1024 * 1024 ;
697 } elsif ( $unit eq 'G' ) {
698 $size = $size * 1024 * 1024 * 1024 ;
699 } elsif ( $unit eq 'T' ) {
700 $size = $size * 1024 * 1024 * 1024 * 1024 ;
711 my $kb = int ( $size/1024 );
712 return $size if $kb*1024 != $size ;
714 my $mb = int ( $kb/1024 );
715 return "${kb}K" if $mb*1024 != $kb ;
717 my $gb = int ( $mb/1024 );
718 return "${mb}M" if $gb*1024 != $mb ;
720 my $tb = int ( $gb/1024 );
721 return "${gb}G" if $tb*1024 != $gb ;
728 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
729 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
733 sub parse_property_string
{
734 my ( $format, $data, $path, $additional_properties ) = @_ ;
736 # In property strings we default to not allowing additional properties
737 $additional_properties = 0 if ! defined ( $additional_properties );
739 # Support named formats here, too:
741 if ( my $desc = $format_list ->{ $format }) {
744 die "unknown format: $format\n " ;
746 } elsif ( ref ( $format ) ne 'HASH' ) {
747 die "unexpected format value of type " . ref ( $format ). " \n " ;
753 foreach my $part ( split ( /,/ , $data )) {
754 next if $part =~ /^\s*$/ ;
756 if ( $part =~ /^([^=]+)=(.+)$/ ) {
757 my ( $k, $v ) = ( $1, $2 );
758 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
759 my $schema = $format ->{ $k };
760 if ( my $alias = $schema ->{ alias
}) {
761 if ( my $key_alias = $schema ->{ keyAlias
}) {
762 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
763 $res ->{ $key_alias } = $k ;
766 $schema = $format ->{ $k };
769 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
770 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
771 $v = parse_boolean
( $v ) // $v ;
774 } elsif ( $part !~ /=/ ) {
775 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
776 foreach my $key ( keys %$format ) {
777 if ( $format ->{ $key }->{ default_key
}) {
779 if (! $res ->{ $default_key }) {
780 $res ->{ $default_key } = $part ;
783 die "duplicate key in comma-separated list property: $default_key\n " ;
786 die "value without key, but schema does not define a default key \n " if ! $default_key ;
788 die "missing key in comma-separated list property \n " ;
793 check_object
( $path, $format, $res, $additional_properties, $errors );
794 if ( scalar ( %$errors )) {
795 raise
"format error \n " , errors
=> $errors ;
802 my ( $errors, $path, $msg ) = @_ ;
804 $path = '_root' if ! $path ;
806 if ( $errors ->{ $path }) {
807 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
809 $errors ->{ $path } = $msg ;
816 # see 'man perlretut'
817 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
823 return $value =~ m/^[+-]?\d+$/ ;
827 my ( $path, $type, $value, $errors ) = @_ ;
831 if (! defined ( $value )) {
832 return 1 if $type eq 'null' ;
836 if ( my $tt = ref ( $type )) {
837 if ( $tt eq 'ARRAY' ) {
838 foreach my $t ( @$type ) {
840 check_type
( $path, $t, $value, $tmperr );
841 return 1 if ! scalar ( %$tmperr );
843 my $ttext = join ( '|' , @$type );
844 add_error
( $errors, $path, "type check (' $ttext ') failed" );
846 } elsif ( $tt eq 'HASH' ) {
848 check_prop
( $value, $type, $path, $tmperr );
849 return 1 if ! scalar ( %$tmperr );
850 add_error
( $errors, $path, "type check failed" );
853 die "internal error - got reference type ' $tt '" ;
858 return 1 if $type eq 'any' ;
860 if ( $type eq 'null' ) {
861 if ( defined ( $value )) {
862 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
868 my $vt = ref ( $value );
870 if ( $type eq 'array' ) {
871 if (! $vt || $vt ne 'ARRAY' ) {
872 add_error
( $errors, $path, "type check (' $type ') failed" );
876 } elsif ( $type eq 'object' ) {
877 if (! $vt || $vt ne 'HASH' ) {
878 add_error
( $errors, $path, "type check (' $type ') failed" );
882 } elsif ( $type eq 'coderef' ) {
883 if (! $vt || $vt ne 'CODE' ) {
884 add_error
( $errors, $path, "type check (' $type ') failed" );
888 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
889 # qr// regexes can be used as strings and make sense for format=regex
893 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
896 if ( $type eq 'string' ) {
897 return 1 ; # nothing to check ?
898 } elsif ( $type eq 'boolean' ) {
899 #if ($value =~ m/^(1|true|yes|on)$/i) {
902 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
903 } elsif ( $value eq '0' ) {
904 return 1 ; # return success (not value)
906 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
909 } elsif ( $type eq 'integer' ) {
910 if (! is_integer
( $value )) {
911 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
915 } elsif ( $type eq 'number' ) {
916 if (! is_number
( $value )) {
917 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
922 return 1 ; # no need to verify unknown types
932 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
934 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
936 my $st = ref ( $schema );
937 if (! $st || $st ne 'HASH' ) {
938 add_error
( $errors, $path, "Invalid schema definition." );
942 my $vt = ref ( $value );
943 if (! $vt || $vt ne 'HASH' ) {
944 add_error
( $errors, $path, "an object is required" );
948 foreach my $k ( keys %$schema ) {
949 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
952 foreach my $k ( keys %$value ) {
954 my $newpath = $path ?
" $path . $k " : $k ;
956 if ( my $subschema = $schema ->{ $k }) {
957 if ( my $requires = $subschema ->{ requires
}) {
958 if ( ref ( $requires )) {
959 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
960 check_prop
( $value, $requires, $path, $errors );
961 } elsif (! defined ( $value ->{ $requires })) {
962 add_error
( $errors, $path ?
" $path . $requires " : $requires,
963 "missing property - ' $newpath ' requires this property" );
967 next ; # value is already checked above
970 if ( defined ( $additional_properties ) && ! $additional_properties ) {
971 add_error
( $errors, $newpath, "property is not defined in schema " .
972 "and the schema does not allow additional properties" );
975 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
976 if ref ( $additional_properties );
980 sub check_object_warn
{
981 my ( $path, $schema, $value, $additional_properties ) = @_ ;
983 check_object
( $path, $schema, $value, $additional_properties, $errors );
984 if ( scalar ( %$errors )) {
985 foreach my $k ( keys %$errors ) {
986 warn "parse error: $k : $errors ->{ $k } \n " ;
994 my ( $value, $schema, $path, $errors ) = @_ ;
996 die "internal error - no schema" if ! $schema ;
997 die "internal error" if ! $errors ;
999 #print "check_prop $path\n" if $value;
1001 my $st = ref ( $schema );
1002 if (! $st || $st ne 'HASH' ) {
1003 add_error
( $errors, $path, "Invalid schema definition." );
1007 # if it extends another schema, it must pass that schema as well
1008 if ( $schema ->{ extends
}) {
1009 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
1012 if (! defined ( $value )) {
1013 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
1014 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
1015 add_error
( $errors, $path, "property is missing and it is not optional" );
1020 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
1022 if ( $schema ->{ disallow
}) {
1024 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
1025 add_error
( $errors, $path, "disallowed value was matched" );
1030 if ( my $vt = ref ( $value )) {
1032 if ( $vt eq 'ARRAY' ) {
1033 if ( $schema ->{ items
}) {
1034 my $it = ref ( $schema ->{ items
});
1035 if ( $it && $it eq 'ARRAY' ) {
1036 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1037 die "not implemented" ;
1040 foreach my $el ( @$value ) {
1041 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
1047 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
1048 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
1049 $value, $schema ->{ additionalProperties
}, $errors );
1055 if ( my $format = $schema ->{ format
}) {
1056 eval { check_format
( $format, $value, $path ); };
1058 add_error
( $errors, $path, "invalid format - $@ " );
1063 if ( my $pattern = $schema ->{ pattern
}) {
1064 if ( $value !~ m/^$pattern$/ ) {
1065 add_error
( $errors, $path, "value does not match the regex pattern" );
1070 if ( defined ( my $max = $schema ->{ maxLength
})) {
1071 if ( length ( $value ) > $max ) {
1072 add_error
( $errors, $path, "value may only be $max characters long" );
1077 if ( defined ( my $min = $schema ->{ minLength
})) {
1078 if ( length ( $value ) < $min ) {
1079 add_error
( $errors, $path, "value must be at least $min characters long" );
1084 if ( is_number
( $value )) {
1085 if ( defined ( my $max = $schema ->{ maximum
})) {
1086 if ( $value > $max ) {
1087 add_error
( $errors, $path, "value must have a maximum value of $max " );
1092 if ( defined ( my $min = $schema ->{ minimum
})) {
1093 if ( $value < $min ) {
1094 add_error
( $errors, $path, "value must have a minimum value of $min " );
1100 if ( my $ea = $schema ->{ enum
}) {
1103 foreach my $ev ( @$ea ) {
1104 if ( $ev eq $value ) {
1110 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
1111 join ( ", " , @$ea ) . "'" );
1118 my ( $instance, $schema, $errmsg ) = @_ ;
1121 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1123 # todo: cycle detection is only needed for debugging, I guess
1124 # we can disable that in the final release
1125 # todo: is there a better/faster way to detect cycles?
1127 find_cycle
( $instance, sub { $cycles = 1 });
1129 add_error
( $errors, undef , "data structure contains recursive cycles" );
1131 check_prop
( $instance, $schema, '' , $errors );
1134 if ( scalar ( %$errors )) {
1135 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1141 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1142 my $default_schema_noref = {
1143 description
=> "This is the JSON Schema for JSON Schemas." ,
1144 type
=> [ "object" ],
1145 additionalProperties
=> 0 ,
1148 type
=> [ "string" , "array" ],
1149 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1154 enum
=> $schema_valid_types,
1156 enum
=> $schema_valid_types,
1160 description
=> "This indicates that the instance property in the instance object is not required." ,
1166 description
=> "This is a definition for the properties of an object value" ,
1172 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1176 additionalProperties
=> {
1177 type
=> [ "boolean" , "object" ],
1178 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1185 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1190 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1194 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1201 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1207 description
=> "A text representation of the type (used to generate documentation)." ,
1212 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." ,
1219 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1224 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)." ,
1226 verbose_description
=> {
1229 description
=> "This provides a more verbose description." ,
1231 format_description
=> {
1234 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1239 description
=> "This provides the title of the property" ,
1244 description
=> "This is used to provide rendering hints to format cli command output." ,
1247 type
=> [ "string" , "object" ],
1249 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1252 type
=> [ "string" , "object" ],
1254 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" ,
1259 description
=> "Whether this is the default key in a comma separated list property string." ,
1264 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." ,
1269 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1270 requires
=> 'alias' ,
1275 description
=> "This indicates the default for the instance property."
1279 description
=> "Bash completion function. This function should return a list of possible values." ,
1285 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." ,
1290 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1293 # this is from hyper schema
1296 description
=> "This defines the link relations of the instance objects" ,
1303 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" ,
1307 description
=> "This is the name of the link relation" ,
1313 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1322 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1328 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1330 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1331 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1333 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1334 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1336 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1337 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1339 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1340 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1342 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1343 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1345 my $method_schema = {
1347 additionalProperties
=> 0 ,
1350 description
=> "This a description of the method" ,
1355 description
=> "This indicates the name of the function to call." ,
1358 additionalProperties
=> 1 ,
1373 description
=> "The HTTP method name." ,
1374 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1379 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1384 description
=> "Method is available for clients authenticated using an API token." ,
1390 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1395 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1398 proxyto_callback
=> {
1400 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1405 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1407 additionalProperties
=> 0 ,
1410 description
=> "Describe access permissions." ,
1414 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1416 enum
=> [ 'all' , 'world' ],
1420 description
=> "Array of permission checks (prefix notation)." ,
1427 description
=> "Used internally" ,
1431 description
=> "Used internally" ,
1436 description
=> "path for URL matching (uri template)" ,
1438 fragmentDelimiter
=> {
1440 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." ,
1445 description
=> "JSON Schema for parameters." ,
1450 description
=> "JSON Schema for return value." ,
1455 description
=> "method implementation (code reference)" ,
1460 description
=> "Delegate call to this class (perl class string)." ,
1463 additionalProperties
=> 0 ,
1469 fragmentDelimiter
=> { optional
=> 1 }
1477 sub validate_schema
{
1480 my $errmsg = "internal error - unable to verify schema \n " ;
1481 validate
( $schema, $default_schema, $errmsg );
1484 sub validate_method_info
{
1487 my $errmsg = "internal error - unable to verify method info \n " ;
1488 validate
( $info, $method_schema, $errmsg );
1490 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1491 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1494 # run a self test on load
1495 # make sure we can verify the default schema
1496 validate_schema
( $default_schema_noref );
1497 validate_schema
( $method_schema );
1499 # and now some utility methods (used by pve api)
1500 sub method_get_child_link
{
1503 return undef if ! $info ;
1505 my $schema = $info ->{ returns
};
1506 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1508 my $links = $schema ->{ links
};
1509 return undef if ! $links ;
1512 foreach my $lnk ( @$links ) {
1513 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1522 # a way to parse command line parameters, using a
1523 # schema to configure Getopt::Long
1525 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1527 if (! $schema || ! $schema ->{ properties
}) {
1528 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1529 if scalar ( @$args ) != 0 ;
1534 if ( $arg_param && ! ref ( $arg_param )) {
1535 my $pd = $schema ->{ properties
}->{ $arg_param };
1536 die "expected list format $pd ->{format}"
1537 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1538 $list_param = $arg_param ;
1541 my @interactive = ();
1543 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1544 my $pd = $schema ->{ properties
}->{ $prop };
1545 next if $list_param && $prop eq $list_param ;
1546 next if defined ( $fixed_param ->{ $prop });
1548 my $mapping = $param_mapping_hash ->{ $prop };
1549 if ( $mapping && $mapping ->{ interactive
}) {
1550 # interactive parameters such as passwords: make the argument
1551 # optional and call the mapping function afterwards.
1552 push @getopt, " $prop :s" ;
1553 push @interactive, [ $prop, $mapping ->{ func
}];
1554 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1555 push @getopt, " $prop :s" ;
1557 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1558 push @getopt, " $prop =s@" ;
1560 push @getopt, " $prop =s" ;
1565 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1568 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1569 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1573 $opts ->{ $list_param } = $args ;
1575 } elsif ( ref ( $arg_param )) {
1576 foreach my $arg_name ( @$arg_param ) {
1577 if ( $opts ->{ 'extra-args' }) {
1578 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1580 if ( $arg_name eq 'extra-args' ) {
1581 $opts ->{ 'extra-args' } = $args ;
1585 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1586 $opts ->{ $arg_name } = shift @$args ;
1588 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1590 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1591 if scalar ( @$args ) != 0 ;
1594 if ( ref ( $arg_param )) {
1595 foreach my $arg_name ( @$arg_param ) {
1596 if ( $arg_name eq 'extra-args' ) {
1597 $opts ->{ 'extra-args' } = [];
1599 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1605 foreach my $entry ( @interactive ) {
1606 my ( $opt, $func ) = @$entry ;
1607 my $pd = $schema ->{ properties
}->{ $opt };
1608 my $value = $opts ->{ $opt };
1609 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1610 $opts ->{ $opt } = $func ->( $value );
1614 # decode after Getopt as we are not sure how well it handles unicode
1615 foreach my $p ( keys %$opts ) {
1616 if (! ref ( $opts ->{ $p })) {
1617 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1618 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1620 foreach my $v (@{ $opts ->{ $p }}) {
1621 push @$tmp, decode
( 'locale' , $v );
1624 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1625 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1627 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1631 foreach my $p ( keys %$opts ) {
1632 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1633 if ( $pd ->{ type
} eq 'boolean' ) {
1634 if ( $opts ->{ $p } eq '' ) {
1636 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1637 $opts ->{ $p } = $bool ;
1639 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1641 } elsif ( $pd ->{ format
}) {
1643 if ( $pd ->{ format
} =~ m/-list/ ) {
1644 # allow --vmid 100 --vmid 101 and --vmid 100,101
1645 # allow --dow mon --dow fri and --dow mon,fri
1646 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1647 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1648 # we encode array as \0 separated strings
1649 # Note: CGI.pm also use this encoding
1650 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1651 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1653 # st that split_list knows it is \0 terminated
1654 my $v = $opts ->{ $p }->[ 0 ];
1655 $opts ->{ $p } = " $v\0 " ;
1662 foreach my $p ( keys %$fixed_param ) {
1663 $opts ->{ $p } = $fixed_param ->{ $p };
1669 # A way to parse configuration data by giving a json schema
1671 my ( $schema, $filename, $raw ) = @_ ;
1673 # do fast check (avoid validate_schema($schema))
1674 die "got strange schema" if ! $schema ->{ type
} ||
1675 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1679 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1682 next if $line =~ /^#/ ;
1684 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1687 if ( $schema ->{ properties
}->{ $key } &&
1688 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1690 $value = parse_boolean
( $value ) // $value ;
1692 $cfg ->{ $key } = $value ;
1694 warn "ignore config line: $line\n "
1699 check_prop
( $cfg, $schema, '' , $errors );
1701 foreach my $k ( keys %$errors ) {
1702 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1709 # generate simple key/value file
1711 my ( $schema, $filename, $cfg ) = @_ ;
1713 # do fast check (avoid validate_schema($schema))
1714 die "got strange schema" if ! $schema ->{ type
} ||
1715 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1717 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1721 foreach my $k ( sort keys %$cfg ) {
1722 $data .= " $k : $cfg ->{ $k } \n " ;
1728 # helpers used to generate our manual pages
1730 my $find_schema_default_key = sub {
1734 my $keyAliasProps = {};
1736 foreach my $key ( keys %$format ) {
1737 my $phash = $format ->{ $key };
1738 if ( $phash ->{ default_key
}) {
1739 die "multiple default keys in schema ( $default_key, $key ) \n "
1740 if defined ( $default_key );
1741 die "default key ' $key ' is an alias - this is not allowed \n "
1742 if defined ( $phash ->{ alias
});
1743 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1744 if $phash ->{ keyAlias
};
1745 $default_key = $key ;
1747 my $key_alias = $phash ->{ keyAlias
};
1748 die "found keyAlias without 'alias definition for ' $key ' \n "
1749 if $key_alias && ! $phash ->{ alias
};
1751 if ( $phash ->{ alias
} && $key_alias ) {
1752 die "inconsistent keyAlias ' $key_alias ' definition"
1753 if defined ( $keyAliasProps ->{ $key_alias }) &&
1754 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1755 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1759 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1762 sub generate_typetext
{
1763 my ( $format, $list_enums ) = @_ ;
1765 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1770 my $add_option_string = sub {
1771 my ( $text, $optional ) = @_ ;
1777 $text = "[ $text ]" if $optional ;
1782 my $format_key_value = sub {
1783 my ( $key, $phash ) = @_ ;
1785 die "internal error" if defined ( $phash ->{ alias
});
1791 if ( my $desc = $phash ->{ format_description
}) {
1792 $typetext .= "< $desc >" ;
1793 } elsif ( my $text = $phash ->{ typetext
}) {
1795 } elsif ( my $enum = $phash ->{ enum
}) {
1796 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1797 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1799 $typetext .= '<enum>' ;
1801 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1802 $typetext .= '<1|0>' ;
1803 } elsif ( $phash ->{ type
} eq 'integer' ) {
1804 $typetext .= '<integer>' ;
1805 } elsif ( $phash ->{ type
} eq 'number' ) {
1806 $typetext .= '<number>' ;
1808 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1811 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1812 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1814 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1820 my $cond_add_key = sub {
1823 return if $done ->{ $key }; # avoid duplicates
1827 my $phash = $format ->{ $key };
1829 return if ! $phash ; # should not happen
1831 return if $phash ->{ alias
};
1833 & $format_key_value ( $key, $phash );
1837 & $cond_add_key ( $default_key ) if defined ( $default_key );
1839 # add required keys first
1840 foreach my $key ( sort keys %$format ) {
1841 my $phash = $format ->{ $key };
1842 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1846 foreach my $key ( sort keys %$format ) {
1847 & $cond_add_key ( $key );
1850 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1851 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1857 sub print_property_string
{
1858 my ( $data, $format, $skip, $path ) = @_ ;
1860 if ( ref ( $format ) ne 'HASH' ) {
1861 my $schema = get_format
( $format );
1862 die "not a valid format: $format\n " if ! $schema ;
1867 check_object
( $path, $format, $data, undef , $errors );
1868 if ( scalar ( %$errors )) {
1869 raise
"format error" , errors
=> $errors ;
1872 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1877 my $add_option_string = sub {
1880 $res .= ',' if $add_sep ;
1885 my $format_value = sub {
1886 my ( $key, $value, $format ) = @_ ;
1888 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1889 return format_size
( $value );
1891 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1896 my $done = { map { $_ => 1 } @$skip };
1898 my $cond_add_key = sub {
1899 my ( $key, $isdefault ) = @_ ;
1901 return if $done ->{ $key }; # avoid duplicates
1905 my $value = $data ->{ $key };
1907 return if ! defined ( $value );
1909 my $phash = $format ->{ $key };
1911 # try to combine values if we have key aliases
1912 if ( my $combine = $keyAliasProps ->{ $key }) {
1913 if ( defined ( my $combine_value = $data ->{ $combine })) {
1914 my $combine_format = $format ->{ $combine }->{ format
};
1915 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1916 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1917 & $add_option_string ( "${value_str}=${combine_str}" );
1918 $done ->{ $combine } = 1 ;
1923 if ( $phash && $phash ->{ alias
}) {
1924 $phash = $format ->{ $phash ->{ alias
}};
1927 die "invalid key ' $key ' \n " if ! $phash ;
1928 die "internal error" if defined ( $phash ->{ alias
});
1930 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1932 & $add_option_string ( $value_str );
1934 & $add_option_string ( " $key =${value_str}" );
1938 # add default key first
1939 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1941 # add required keys first
1942 foreach my $key ( sort keys %$data ) {
1943 my $phash = $format ->{ $key };
1944 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1948 foreach my $key ( sort keys %$data ) {
1949 & $cond_add_key ( $key );
1955 sub schema_get_type_text
{
1956 my ( $phash, $style ) = @_ ;
1958 my $type = $phash ->{ type
} || 'string' ;
1960 if ( $phash ->{ typetext
}) {
1961 return $phash ->{ typetext
};
1962 } elsif ( $phash ->{ format_description
}) {
1963 return "< $phash ->{format_description}>" ;
1964 } elsif ( $phash ->{ enum
}) {
1965 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
1966 } elsif ( $phash ->{ pattern
}) {
1967 return $phash ->{ pattern
};
1968 } elsif ( $type eq 'integer' || $type eq 'number' ) {
1969 # NOTE: always access values as number (avoid converion to string)
1970 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
1971 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
1972 ( $phash ->{ maximum
} + 0 ) . ")" ;
1973 } elsif ( defined ( $phash ->{ minimum
})) {
1974 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
1975 } elsif ( defined ( $phash ->{ maximum
})) {
1976 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
1978 } elsif ( $type eq 'string' ) {
1979 if ( my $format = $phash ->{ format
}) {
1980 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
1981 if ( ref ( $format ) eq 'HASH' ) {
1983 $list_enums = 1 if $style && $style eq 'config-sub' ;
1984 return generate_typetext
( $format, $list_enums );