]>
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) ;
21 register_standard_option
24 our $CONFIGID_RE = qr/[a-z][a-z0-9_-]+/i ;
26 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
27 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
28 # see: http://json-schema.org/
30 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
32 my $standard_options = {};
33 sub register_standard_option
{
34 my ( $name, $schema ) = @_ ;
36 die "standard option ' $name ' already registered \n "
37 if $standard_options ->{ $name };
39 $standard_options ->{ $name } = $schema ;
42 sub get_standard_option
{
43 my ( $name, $base ) = @_ ;
45 my $std = $standard_options ->{ $name };
46 die "no such standard option ' $name ' \n " if ! $std ;
48 my $res = $base || {};
50 foreach my $opt ( keys %$std ) {
51 next if defined ( $res ->{ $opt });
52 $res ->{ $opt } = $std ->{ $opt };
58 register_standard_option
( 'pve-vmid' , {
59 description
=> "The (unique) ID of the VM." ,
60 type
=> 'integer' , format
=> 'pve-vmid' ,
64 register_standard_option
( 'pve-node' , {
65 description
=> "The cluster node name." ,
66 type
=> 'string' , format
=> 'pve-node' ,
69 register_standard_option
( 'pve-node-list' , {
70 description
=> "List of cluster node names." ,
71 type
=> 'string' , format
=> 'pve-node-list' ,
74 register_standard_option
( 'pve-iface' , {
75 description
=> "Network interface name." ,
76 type
=> 'string' , format
=> 'pve-iface' ,
77 minLength
=> 2 , maxLength
=> 20 ,
80 register_standard_option
( 'pve-storage-id' , {
81 description
=> "The storage identifier." ,
82 type
=> 'string' , format
=> 'pve-storage-id' ,
85 register_standard_option
( 'pve-config-digest' , {
86 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.' ,
89 maxLength
=> 40 , # sha1 hex digest length is 40
92 register_standard_option
( 'skiplock' , {
93 description
=> "Ignore locks - only root is allowed to use this option." ,
98 register_standard_option
( 'extra-args' , {
99 description
=> "Extra arguments as array" ,
101 items
=> { type
=> 'string' },
105 register_standard_option
( 'fingerprint-sha256' , {
106 description
=> "Certificate SHA 256 fingerprint." ,
108 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}' ,
111 register_standard_option
( 'pve-output-format' , {
113 description
=> 'Output format.' ,
114 enum
=> [ 'text' , 'json' , 'json-pretty' , 'yaml' ],
119 register_standard_option
( 'pve-snapshot-name' , {
120 description
=> "The name of the snapshot." ,
121 type
=> 'string' , format
=> 'pve-configid' ,
125 my $format_list = {};
126 my $format_validators = {};
128 sub register_format
{
129 my ( $name, $format, $validator ) = @_ ;
131 die "JSON schema format ' $name ' already registered \n "
132 if $format_list ->{ $name };
135 die "A \ $validator function can only be specified for hash-based formats \n "
136 if ref ( $format ) ne 'HASH' ;
137 $format_validators ->{ $name } = $validator ;
140 $format_list ->{ $name } = $format ;
145 return $format_list ->{ $name };
148 my $renderer_hash = {};
150 sub register_renderer
{
151 my ( $name, $code ) = @_ ;
153 die "renderer ' $name ' already registered \n "
154 if $renderer_hash ->{ $name };
156 $renderer_hash ->{ $name } = $code ;
161 return $renderer_hash ->{ $name };
164 # register some common type for pve
166 register_format
( 'string' , sub {}); # allow format => 'string-list'
168 register_format
( 'urlencoded' , \
& pve_verify_urlencoded
);
169 sub pve_verify_urlencoded
{
170 my ( $text, $noerr ) = @_ ;
171 if ( $text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/ ) {
172 return undef if $noerr ;
173 die "invalid urlencoded string: $text\n " ;
178 register_format
( 'pve-configid' , \
& pve_verify_configid
);
179 sub pve_verify_configid
{
180 my ( $id, $noerr ) = @_ ;
182 if ( $id !~ m/^$CONFIGID_RE$/ ) {
183 return undef if $noerr ;
184 die "invalid configuration ID ' $id ' \n " ;
189 PVE
:: JSONSchema
:: register_format
( 'pve-storage-id' , \
& parse_storage_id
);
190 sub parse_storage_id
{
191 my ( $storeid, $noerr ) = @_ ;
193 return parse_id
( $storeid, 'storage' , $noerr );
196 PVE
:: JSONSchema
:: register_format
( 'acme-plugin-id' , \
& parse_acme_plugin_id
);
197 sub parse_acme_plugin_id
{
198 my ( $pluginid, $noerr ) = @_ ;
200 return parse_id
( $pluginid, 'ACME plugin' , $noerr );
204 my ( $id, $type, $noerr ) = @_ ;
206 if ( $id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
207 return undef if $noerr ;
208 die " $type ID ' $id ' contains illegal characters \n " ;
213 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
214 sub pve_verify_vmid
{
215 my ( $vmid, $noerr ) = @_ ;
217 if ( $vmid !~ m/^[1-9][0-9]{2,8}$/ ) {
218 return undef if $noerr ;
219 die "value does not look like a valid VM ID \n " ;
224 register_format
( 'pve-node' , \
& pve_verify_node_name
);
225 sub pve_verify_node_name
{
226 my ( $node, $noerr ) = @_ ;
228 if ( $node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/ ) {
229 return undef if $noerr ;
230 die "value does not look like a valid node name \n " ;
236 my ( $idmap, $idformat ) = @_ ;
238 return undef if ! $idmap ;
242 foreach my $entry ( PVE
:: Tools
:: split_list
( $idmap )) {
244 $map ->{ identity
} = 1 ;
245 } elsif ( $entry =~ m/^([^:]+):([^:]+)$/ ) {
246 my ( $source, $target ) = ( $1, $2 );
248 check_format
( $idformat, $source, '' );
249 check_format
( $idformat, $target, '' );
251 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
253 die "duplicate mapping for source ' $source ' \n "
254 if exists $map ->{ entries
}->{ $source };
256 $map ->{ entries
}->{ $source } = $target ;
259 check_format
( $idformat, $entry );
261 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
263 die "default target ID can only be provided once \n "
264 if exists $map ->{ default };
266 $map ->{ default } = $entry ;
270 die "identity mapping cannot be combined with other mappings \n "
271 if $map ->{ identity
} && ( $map ->{ default } || exists $map ->{ entries
});
276 register_format
( 'storagepair' , \
& verify_storagepair
);
277 sub verify_storagepair
{
278 my ( $storagepair, $noerr ) = @_ ;
280 # note: this only checks a single list entry
281 # when using a storagepair-list map, you need to pass the full
282 # parameter to parse_idmap
283 eval { parse_idmap
( $storagepair, 'pve-storage-id' ) };
285 return undef if $noerr ;
292 register_format
( 'mac-addr' , \
& pve_verify_mac_addr
);
293 sub pve_verify_mac_addr
{
294 my ( $mac_addr, $noerr ) = @_ ;
296 # don't allow I/G bit to be set, most of the time it breaks things, see:
297 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
298 if ( $mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i ) {
299 return undef if $noerr ;
300 die "value does not look like a valid unicast MAC address \n " ;
305 register_standard_option
( 'mac-addr' , {
307 description
=> 'Unicast MAC address.' ,
308 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.' ,
309 format_description
=> "XX:XX:XX:XX:XX:XX" ,
311 format
=> 'mac-addr' ,
314 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
315 sub pve_verify_ipv4
{
316 my ( $ipv4, $noerr ) = @_ ;
318 if ( $ipv4 !~ m/^(?:$IPV4RE)$/ ) {
319 return undef if $noerr ;
320 die "value does not look like a valid IPv4 address \n " ;
325 register_format
( 'ipv6' , \
& pve_verify_ipv6
);
326 sub pve_verify_ipv6
{
327 my ( $ipv6, $noerr ) = @_ ;
329 if ( $ipv6 !~ m/^(?:$IPV6RE)$/ ) {
330 return undef if $noerr ;
331 die "value does not look like a valid IPv6 address \n " ;
336 register_format
( 'ip' , \
& pve_verify_ip
);
338 my ( $ip, $noerr ) = @_ ;
340 if ( $ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/ ) {
341 return undef if $noerr ;
342 die "value does not look like a valid IP address \n " ;
347 PVE
:: JSONSchema
:: register_format
( 'ldap-simple-attr' , \
& verify_ldap_simple_attr
);
348 sub verify_ldap_simple_attr
{
349 my ( $attr, $noerr ) = @_ ;
351 if ( $attr =~ m/^[a-zA-Z0-9]+$/ ) {
355 die "value ' $attr ' does not look like a simple ldap attribute name \n " if ! $noerr ;
360 my $ipv4_mask_hash = {
378 '255.255.128.0' => 17 ,
379 '255.255.192.0' => 18 ,
380 '255.255.224.0' => 19 ,
381 '255.255.240.0' => 20 ,
382 '255.255.248.0' => 21 ,
383 '255.255.252.0' => 22 ,
384 '255.255.254.0' => 23 ,
385 '255.255.255.0' => 24 ,
386 '255.255.255.128' => 25 ,
387 '255.255.255.192' => 26 ,
388 '255.255.255.224' => 27 ,
389 '255.255.255.240' => 28 ,
390 '255.255.255.248' => 29 ,
391 '255.255.255.252' => 30 ,
392 '255.255.255.254' => 31 ,
393 '255.255.255.255' => 32 ,
396 sub get_netmask_bits
{
398 return $ipv4_mask_hash ->{ $mask };
401 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
402 sub pve_verify_ipv4mask
{
403 my ( $mask, $noerr ) = @_ ;
405 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
406 return undef if $noerr ;
407 die "value does not look like a valid IP netmask \n " ;
412 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
413 sub pve_verify_cidrv6
{
414 my ( $cidr, $noerr ) = @_ ;
416 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
420 return undef if $noerr ;
421 die "value does not look like a valid IPv6 CIDR network \n " ;
424 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
425 sub pve_verify_cidrv4
{
426 my ( $cidr, $noerr ) = @_ ;
428 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
432 return undef if $noerr ;
433 die "value does not look like a valid IPv4 CIDR network \n " ;
436 register_format
( 'CIDR' , \
& pve_verify_cidr
);
437 sub pve_verify_cidr
{
438 my ( $cidr, $noerr ) = @_ ;
440 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
441 pve_verify_cidrv6
( $cidr, 1 )))
443 return undef if $noerr ;
444 die "value does not look like a valid CIDR network \n " ;
450 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
451 sub pve_verify_ipv4_config
{
452 my ( $config, $noerr ) = @_ ;
454 return $config if $config =~ /^(?:dhcp|manual)$/ ||
455 pve_verify_cidrv4
( $config, 1 );
456 return undef if $noerr ;
457 die "value does not look like a valid ipv4 network configuration \n " ;
460 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
461 sub pve_verify_ipv6_config
{
462 my ( $config, $noerr ) = @_ ;
464 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
465 pve_verify_cidrv6
( $config, 1 );
466 return undef if $noerr ;
467 die "value does not look like a valid ipv6 network configuration \n " ;
470 register_format
( 'email' , \
& pve_verify_email
);
471 sub pve_verify_email
{
472 my ( $email, $noerr ) = @_ ;
474 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
475 return undef if $noerr ;
476 die "value does not look like a valid email address \n " ;
481 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
482 sub pve_verify_dns_name
{
483 my ( $name, $noerr ) = @_ ;
485 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
487 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
488 return undef if $noerr ;
489 die "value does not look like a valid DNS name \n " ;
494 register_format
( 'timezone' , \
& pve_verify_timezone
);
495 sub pve_verify_timezone
{
496 my ( $timezone, $noerr ) = @_ ;
498 return $timezone if $timezone eq 'UTC' ;
500 open ( my $fh, "<" , "/usr/share/zoneinfo/zone.tab" );
501 while ( my $line = < $fh >) {
502 next if $line =~ /^\s*#/ ;
504 my $zone = ( split /\t/ , $line )[ 2 ];
505 return $timezone if $timezone eq $zone ; # found
509 return undef if $noerr ;
510 die "invalid time zone ' $timezone ' \n " ;
513 # network interface name
514 register_format
( 'pve-iface' , \
& pve_verify_iface
);
515 sub pve_verify_iface
{
516 my ( $id, $noerr ) = @_ ;
518 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
519 return undef if $noerr ;
520 die "invalid network interface name ' $id ' \n " ;
525 # general addresses by name or IP
526 register_format
( 'address' , \
& pve_verify_address
);
527 sub pve_verify_address
{
528 my ( $addr, $noerr ) = @_ ;
530 if (!( pve_verify_ip
( $addr, 1 ) ||
531 pve_verify_dns_name
( $addr, 1 )))
533 return undef if $noerr ;
534 die "value does not look like a valid address: $addr\n " ;
539 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
540 sub pve_verify_disk_size
{
541 my ( $size, $noerr ) = @_ ;
542 if (! defined ( parse_size
( $size ))) {
543 return undef if $noerr ;
544 die "value does not look like a valid disk size: $size\n " ;
549 register_standard_option
( 'spice-proxy' , {
550 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)." ,
551 type
=> 'string' , format
=> 'address' ,
554 register_standard_option
( 'remote-viewer-config' , {
555 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
556 additionalProperties
=> 1 ,
558 type
=> { type
=> 'string' },
559 password
=> { type
=> 'string' },
560 proxy
=> { type
=> 'string' },
561 host
=> { type
=> 'string' },
562 'tls-port' => { type
=> 'integer' },
566 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
567 sub pve_verify_startup_order
{
568 my ( $value, $noerr ) = @_ ;
570 return $value if pve_parse_startup_order
( $value );
572 return undef if $noerr ;
574 die "unable to parse startup options \n " ;
579 type
=> 'number' , minimum
=> '0' ,
580 format_description
=> 'LIMIT' ,
583 my $bwlimit_format = {
586 description
=> 'default bandwidth limit in KiB/s' ,
590 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
594 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
598 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
602 description
=> 'bandwidth limit in KiB/s for moving disks' ,
605 register_format
( 'bwlimit' , $bwlimit_format );
606 register_standard_option
( 'bwlimit' , {
607 description
=> "Set bandwidth/io limits various operations." ,
610 format
=> $bwlimit_format,
613 # used for pve-tag-list in e.g., guest configs
614 register_format
( 'pve-tag' , \
& pve_verify_tag
);
616 my ( $value, $noerr ) = @_ ;
618 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i ;
620 return undef if $noerr ;
622 die "invalid characters in tag \n " ;
625 sub pve_parse_startup_order
{
628 return undef if ! $value ;
632 foreach my $p ( split ( /,/ , $value )) {
633 next if $p =~ m/^\s*$/ ;
635 if ( $p =~ m/^(order=)?(\d+)$/ ) {
637 } elsif ( $p =~ m/^up=(\d+)$/ ) {
639 } elsif ( $p =~ m/^down=(\d+)$/ ) {
649 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
650 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." ,
652 type
=> 'string' , format
=> 'pve-startup-order' ,
653 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
656 register_format
( 'pve-tfa-secret' , \
& pve_verify_tfa_secret
);
657 sub pve_verify_tfa_secret
{
658 my ( $key, $noerr ) = @_ ;
660 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
661 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
662 # format to support arbitrary lengths properly:
663 if ( $key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
664 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
665 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/ ) # and the old pattern copy&pasted
670 return undef if $noerr ;
672 die "unable to decode TFA secret \n " ;
676 my ( $format, $value, $path ) = @_ ;
678 if ( ref ( $format ) eq 'HASH' ) {
679 # hash ref cannot have validator/list/opt handling attached
680 return parse_property_string
( $format, $value, $path );
683 if ( ref ( $format ) eq 'CODE' ) {
684 # we are the (sole, old-style) validator
685 return $format ->( $value );
688 return if $format eq 'regex' ;
691 $format =~ m/^(.*?)(?:-a?(list|opt))?$/ ;
692 my ( $format_name, $format_type ) = ( $1, $2 // 'none' );
693 my $registered = get_format
( $format_name );
694 die "undefined format ' $format ' \n " if ! $registered ;
696 die "'- $format_type ' format must have code ref, not hash \n "
697 if $format_type ne 'none' && ref ( $registered ) ne 'CODE' ;
699 if ( $format_type eq 'list' ) {
700 # Note: we allow empty lists
701 foreach my $v ( split_list
( $value )) {
702 $parsed = $registered ->( $v );
704 } elsif ( $format_type eq 'opt' ) {
705 $parsed = $registered ->( $value ) if $value ;
707 if ( ref ( $registered ) eq 'HASH' ) {
708 # Note: this is the only case where a validator function could be
709 # attached, hence it's safe to handle that in parse_property_string.
710 # We do however have to call it with $format_name instead of
711 # $registered, so it knows about the name (and thus any validators).
712 $parsed = parse_property_string
( $format, $value, $path );
714 $parsed = $registered ->( $value );
724 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
725 my ( $size, $unit ) = ( $1, $3 );
728 $size = $size * 1024 ;
729 } elsif ( $unit eq 'M' ) {
730 $size = $size * 1024 * 1024 ;
731 } elsif ( $unit eq 'G' ) {
732 $size = $size * 1024 * 1024 * 1024 ;
733 } elsif ( $unit eq 'T' ) {
734 $size = $size * 1024 * 1024 * 1024 * 1024 ;
745 my $kb = int ( $size/1024 );
746 return $size if $kb*1024 != $size ;
748 my $mb = int ( $kb/1024 );
749 return "${kb}K" if $mb*1024 != $kb ;
751 my $gb = int ( $mb/1024 );
752 return "${mb}M" if $gb*1024 != $mb ;
754 my $tb = int ( $gb/1024 );
755 return "${gb}G" if $tb*1024 != $gb ;
762 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
763 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
767 sub parse_property_string
{
768 my ( $format, $data, $path, $additional_properties ) = @_ ;
770 # In property strings we default to not allowing additional properties
771 $additional_properties = 0 if ! defined ( $additional_properties );
773 # Support named formats here, too:
776 if ( my $reg = get_format
( $format )) {
777 die "parse_property_string only accepts hash based named formats \n "
778 if ref ( $reg ) ne 'HASH' ;
780 # named formats can have validators attached
781 $validator = $format_validators ->{ $format };
785 die "unknown format: $format\n " ;
787 } elsif ( ref ( $format ) ne 'HASH' ) {
788 die "unexpected format value of type " . ref ( $format ). " \n " ;
794 foreach my $part ( split ( /,/ , $data )) {
795 next if $part =~ /^\s*$/ ;
797 if ( $part =~ /^([^=]+)=(.+)$/ ) {
798 my ( $k, $v ) = ( $1, $2 );
799 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
800 my $schema = $format ->{ $k };
801 if ( my $alias = $schema ->{ alias
}) {
802 if ( my $key_alias = $schema ->{ keyAlias
}) {
803 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
804 $res ->{ $key_alias } = $k ;
807 $schema = $format ->{ $k };
810 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
811 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
812 $v = parse_boolean
( $v ) // $v ;
815 } elsif ( $part !~ /=/ ) {
816 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
817 foreach my $key ( keys %$format ) {
818 if ( $format ->{ $key }->{ default_key
}) {
820 if (! $res ->{ $default_key }) {
821 $res ->{ $default_key } = $part ;
824 die "duplicate key in comma-separated list property: $default_key\n " ;
827 die "value without key, but schema does not define a default key \n " if ! $default_key ;
829 die "missing key in comma-separated list property \n " ;
834 check_object
( $path, $format, $res, $additional_properties, $errors );
835 if ( scalar ( %$errors )) {
836 raise
"format error \n " , errors
=> $errors ;
839 return $validator ->( $res ) if $validator ;
844 my ( $errors, $path, $msg ) = @_ ;
846 $path = '_root' if ! $path ;
848 if ( $errors ->{ $path }) {
849 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
851 $errors ->{ $path } = $msg ;
858 # see 'man perlretut'
859 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
865 return $value =~ m/^[+-]?\d+$/ ;
869 my ( $path, $type, $value, $errors ) = @_ ;
873 if (! defined ( $value )) {
874 return 1 if $type eq 'null' ;
878 if ( my $tt = ref ( $type )) {
879 if ( $tt eq 'ARRAY' ) {
880 foreach my $t ( @$type ) {
882 check_type
( $path, $t, $value, $tmperr );
883 return 1 if ! scalar ( %$tmperr );
885 my $ttext = join ( '|' , @$type );
886 add_error
( $errors, $path, "type check (' $ttext ') failed" );
888 } elsif ( $tt eq 'HASH' ) {
890 check_prop
( $value, $type, $path, $tmperr );
891 return 1 if ! scalar ( %$tmperr );
892 add_error
( $errors, $path, "type check failed" );
895 die "internal error - got reference type ' $tt '" ;
900 return 1 if $type eq 'any' ;
902 if ( $type eq 'null' ) {
903 if ( defined ( $value )) {
904 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
910 my $vt = ref ( $value );
912 if ( $type eq 'array' ) {
913 if (! $vt || $vt ne 'ARRAY' ) {
914 add_error
( $errors, $path, "type check (' $type ') failed" );
918 } elsif ( $type eq 'object' ) {
919 if (! $vt || $vt ne 'HASH' ) {
920 add_error
( $errors, $path, "type check (' $type ') failed" );
924 } elsif ( $type eq 'coderef' ) {
925 if (! $vt || $vt ne 'CODE' ) {
926 add_error
( $errors, $path, "type check (' $type ') failed" );
930 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
931 # qr// regexes can be used as strings and make sense for format=regex
935 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
938 if ( $type eq 'string' ) {
939 return 1 ; # nothing to check ?
940 } elsif ( $type eq 'boolean' ) {
941 #if ($value =~ m/^(1|true|yes|on)$/i) {
944 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
945 } elsif ( $value eq '0' ) {
946 return 1 ; # return success (not value)
948 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
951 } elsif ( $type eq 'integer' ) {
952 if (! is_integer
( $value )) {
953 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
957 } elsif ( $type eq 'number' ) {
958 if (! is_number
( $value )) {
959 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
964 return 1 ; # no need to verify unknown types
974 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
976 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
978 my $st = ref ( $schema );
979 if (! $st || $st ne 'HASH' ) {
980 add_error
( $errors, $path, "Invalid schema definition." );
984 my $vt = ref ( $value );
985 if (! $vt || $vt ne 'HASH' ) {
986 add_error
( $errors, $path, "an object is required" );
990 foreach my $k ( keys %$schema ) {
991 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
994 foreach my $k ( keys %$value ) {
996 my $newpath = $path ?
" $path . $k " : $k ;
998 if ( my $subschema = $schema ->{ $k }) {
999 if ( my $requires = $subschema ->{ requires
}) {
1000 if ( ref ( $requires )) {
1001 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1002 check_prop
( $value, $requires, $path, $errors );
1003 } elsif (! defined ( $value ->{ $requires })) {
1004 add_error
( $errors, $path ?
" $path . $requires " : $requires,
1005 "missing property - ' $newpath ' requires this property" );
1009 next ; # value is already checked above
1012 if ( defined ( $additional_properties ) && ! $additional_properties ) {
1013 add_error
( $errors, $newpath, "property is not defined in schema " .
1014 "and the schema does not allow additional properties" );
1017 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
1018 if ref ( $additional_properties );
1022 sub check_object_warn
{
1023 my ( $path, $schema, $value, $additional_properties ) = @_ ;
1025 check_object
( $path, $schema, $value, $additional_properties, $errors );
1026 if ( scalar ( %$errors )) {
1027 foreach my $k ( keys %$errors ) {
1028 warn "parse error: $k : $errors ->{ $k } \n " ;
1036 my ( $value, $schema, $path, $errors ) = @_ ;
1038 die "internal error - no schema" if ! $schema ;
1039 die "internal error" if ! $errors ;
1041 #print "check_prop $path\n" if $value;
1043 my $st = ref ( $schema );
1044 if (! $st || $st ne 'HASH' ) {
1045 add_error
( $errors, $path, "Invalid schema definition." );
1049 # if it extends another schema, it must pass that schema as well
1050 if ( $schema ->{ extends
}) {
1051 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
1054 if (! defined ( $value )) {
1055 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
1056 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
1057 add_error
( $errors, $path, "property is missing and it is not optional" );
1062 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
1064 if ( $schema ->{ disallow
}) {
1066 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
1067 add_error
( $errors, $path, "disallowed value was matched" );
1072 if ( my $vt = ref ( $value )) {
1074 if ( $vt eq 'ARRAY' ) {
1075 if ( $schema ->{ items
}) {
1076 my $it = ref ( $schema ->{ items
});
1077 if ( $it && $it eq 'ARRAY' ) {
1078 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1079 die "not implemented" ;
1082 foreach my $el ( @$value ) {
1083 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
1089 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
1090 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
1091 $value, $schema ->{ additionalProperties
}, $errors );
1097 if ( my $format = $schema ->{ format
}) {
1098 eval { check_format
( $format, $value, $path ); };
1100 add_error
( $errors, $path, "invalid format - $@ " );
1105 if ( my $pattern = $schema ->{ pattern
}) {
1106 if ( $value !~ m/^$pattern$/ ) {
1107 add_error
( $errors, $path, "value does not match the regex pattern" );
1112 if ( defined ( my $max = $schema ->{ maxLength
})) {
1113 if ( length ( $value ) > $max ) {
1114 add_error
( $errors, $path, "value may only be $max characters long" );
1119 if ( defined ( my $min = $schema ->{ minLength
})) {
1120 if ( length ( $value ) < $min ) {
1121 add_error
( $errors, $path, "value must be at least $min characters long" );
1126 if ( is_number
( $value )) {
1127 if ( defined ( my $max = $schema ->{ maximum
})) {
1128 if ( $value > $max ) {
1129 add_error
( $errors, $path, "value must have a maximum value of $max " );
1134 if ( defined ( my $min = $schema ->{ minimum
})) {
1135 if ( $value < $min ) {
1136 add_error
( $errors, $path, "value must have a minimum value of $min " );
1142 if ( my $ea = $schema ->{ enum
}) {
1145 foreach my $ev ( @$ea ) {
1146 if ( $ev eq $value ) {
1152 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
1153 join ( ", " , @$ea ) . "'" );
1160 my ( $instance, $schema, $errmsg ) = @_ ;
1163 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1165 # todo: cycle detection is only needed for debugging, I guess
1166 # we can disable that in the final release
1167 # todo: is there a better/faster way to detect cycles?
1169 find_cycle
( $instance, sub { $cycles = 1 });
1171 add_error
( $errors, undef , "data structure contains recursive cycles" );
1173 check_prop
( $instance, $schema, '' , $errors );
1176 if ( scalar ( %$errors )) {
1177 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1183 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1184 my $default_schema_noref = {
1185 description
=> "This is the JSON Schema for JSON Schemas." ,
1186 type
=> [ "object" ],
1187 additionalProperties
=> 0 ,
1190 type
=> [ "string" , "array" ],
1191 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1196 enum
=> $schema_valid_types,
1198 enum
=> $schema_valid_types,
1202 description
=> "This indicates that the instance property in the instance object is not required." ,
1208 description
=> "This is a definition for the properties of an object value" ,
1214 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1218 additionalProperties
=> {
1219 type
=> [ "boolean" , "object" ],
1220 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1227 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1232 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1236 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1243 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1249 description
=> "A text representation of the type (used to generate documentation)." ,
1254 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." ,
1261 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1266 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)." ,
1268 verbose_description
=> {
1271 description
=> "This provides a more verbose description." ,
1273 format_description
=> {
1276 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1281 description
=> "This provides the title of the property" ,
1286 description
=> "This is used to provide rendering hints to format cli command output." ,
1289 type
=> [ "string" , "object" ],
1291 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1294 type
=> [ "string" , "object" ],
1296 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" ,
1301 description
=> "Whether this is the default key in a comma separated list property string." ,
1306 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." ,
1311 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1312 requires
=> 'alias' ,
1317 description
=> "This indicates the default for the instance property."
1321 description
=> "Bash completion function. This function should return a list of possible values." ,
1327 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." ,
1332 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1335 # this is from hyper schema
1338 description
=> "This defines the link relations of the instance objects" ,
1345 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" ,
1349 description
=> "This is the name of the link relation" ,
1355 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1364 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1370 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1372 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1373 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1375 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1376 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1378 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1379 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1381 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1382 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1384 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1385 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1387 my $method_schema = {
1389 additionalProperties
=> 0 ,
1392 description
=> "This a description of the method" ,
1397 description
=> "This indicates the name of the function to call." ,
1400 additionalProperties
=> 1 ,
1415 description
=> "The HTTP method name." ,
1416 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1421 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1426 description
=> "Method is available for clients authenticated using an API token." ,
1432 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1437 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1440 proxyto_callback
=> {
1442 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1447 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1449 additionalProperties
=> 0 ,
1452 description
=> "Describe access permissions." ,
1456 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1458 enum
=> [ 'all' , 'world' ],
1462 description
=> "Array of permission checks (prefix notation)." ,
1469 description
=> "Used internally" ,
1473 description
=> "Used internally" ,
1478 description
=> "path for URL matching (uri template)" ,
1480 fragmentDelimiter
=> {
1482 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." ,
1487 description
=> "JSON Schema for parameters." ,
1492 description
=> "JSON Schema for return value." ,
1497 description
=> "method implementation (code reference)" ,
1502 description
=> "Delegate call to this class (perl class string)." ,
1505 additionalProperties
=> 0 ,
1511 fragmentDelimiter
=> { optional
=> 1 }
1519 sub validate_schema
{
1522 my $errmsg = "internal error - unable to verify schema \n " ;
1523 validate
( $schema, $default_schema, $errmsg );
1526 sub validate_method_info
{
1529 my $errmsg = "internal error - unable to verify method info \n " ;
1530 validate
( $info, $method_schema, $errmsg );
1532 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1533 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1536 # run a self test on load
1537 # make sure we can verify the default schema
1538 validate_schema
( $default_schema_noref );
1539 validate_schema
( $method_schema );
1541 # and now some utility methods (used by pve api)
1542 sub method_get_child_link
{
1545 return undef if ! $info ;
1547 my $schema = $info ->{ returns
};
1548 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1550 my $links = $schema ->{ links
};
1551 return undef if ! $links ;
1554 foreach my $lnk ( @$links ) {
1555 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1564 # a way to parse command line parameters, using a
1565 # schema to configure Getopt::Long
1567 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1569 if (! $schema || ! $schema ->{ properties
}) {
1570 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1571 if scalar ( @$args ) != 0 ;
1576 if ( $arg_param && ! ref ( $arg_param )) {
1577 my $pd = $schema ->{ properties
}->{ $arg_param };
1578 die "expected list format $pd ->{format}"
1579 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1580 $list_param = $arg_param ;
1583 my @interactive = ();
1585 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1586 my $pd = $schema ->{ properties
}->{ $prop };
1587 next if $list_param && $prop eq $list_param ;
1588 next if defined ( $fixed_param ->{ $prop });
1590 my $mapping = $param_mapping_hash ->{ $prop };
1591 if ( $mapping && $mapping ->{ interactive
}) {
1592 # interactive parameters such as passwords: make the argument
1593 # optional and call the mapping function afterwards.
1594 push @getopt, " $prop :s" ;
1595 push @interactive, [ $prop, $mapping ->{ func
}];
1596 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1597 push @getopt, " $prop :s" ;
1599 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1600 push @getopt, " $prop =s@" ;
1602 push @getopt, " $prop =s" ;
1607 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1610 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1611 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1615 $opts ->{ $list_param } = $args ;
1617 } elsif ( ref ( $arg_param )) {
1618 for ( my $i = 0 ; $i < scalar ( @$arg_param ); $i++ ) {
1619 my $arg_name = $arg_param ->[ $i ];
1620 if ( $opts ->{ 'extra-args' }) {
1621 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1623 if ( $arg_name eq 'extra-args' ) {
1624 $opts ->{ 'extra-args' } = $args ;
1629 # check if all left-over arg_param are optional, else we
1630 # must die as the mapping is then ambigious
1631 for ( my $j = $i ; $j < scalar ( @$arg_param ); $j++ ) {
1632 my $prop = $arg_param ->[ $j ];
1633 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
)
1634 if ! $schema ->{ properties
}->{ $prop }->{ optional
};
1637 $opts ->{ $arg_name } = shift @$args ;
1639 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1641 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1642 if scalar ( @$args ) != 0 ;
1645 if ( ref ( $arg_param )) {
1646 foreach my $arg_name ( @$arg_param ) {
1647 if ( $arg_name eq 'extra-args' ) {
1648 $opts ->{ 'extra-args' } = [];
1649 } elsif (! $schema ->{ properties
}->{ $arg_name }->{ optional
}) {
1650 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1656 foreach my $entry ( @interactive ) {
1657 my ( $opt, $func ) = @$entry ;
1658 my $pd = $schema ->{ properties
}->{ $opt };
1659 my $value = $opts ->{ $opt };
1660 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1661 $opts ->{ $opt } = $func ->( $value );
1665 # decode after Getopt as we are not sure how well it handles unicode
1666 foreach my $p ( keys %$opts ) {
1667 if (! ref ( $opts ->{ $p })) {
1668 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1669 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1671 foreach my $v (@{ $opts ->{ $p }}) {
1672 push @$tmp, decode
( 'locale' , $v );
1675 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1676 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1678 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1682 foreach my $p ( keys %$opts ) {
1683 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1684 if ( $pd ->{ type
} eq 'boolean' ) {
1685 if ( $opts ->{ $p } eq '' ) {
1687 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1688 $opts ->{ $p } = $bool ;
1690 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1692 } elsif ( $pd ->{ format
}) {
1694 if ( $pd ->{ format
} =~ m/-list/ ) {
1695 # allow --vmid 100 --vmid 101 and --vmid 100,101
1696 # allow --dow mon --dow fri and --dow mon,fri
1697 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1698 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1699 # we encode array as \0 separated strings
1700 # Note: CGI.pm also use this encoding
1701 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1702 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1704 # st that split_list knows it is \0 terminated
1705 my $v = $opts ->{ $p }->[ 0 ];
1706 $opts ->{ $p } = " $v\0 " ;
1713 foreach my $p ( keys %$fixed_param ) {
1714 $opts ->{ $p } = $fixed_param ->{ $p };
1720 # A way to parse configuration data by giving a json schema
1722 my ( $schema, $filename, $raw ) = @_ ;
1724 # do fast check (avoid validate_schema($schema))
1725 die "got strange schema" if ! $schema ->{ type
} ||
1726 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1730 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1733 next if $line =~ /^#/ ;
1735 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1738 if ( $schema ->{ properties
}->{ $key } &&
1739 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1741 $value = parse_boolean
( $value ) // $value ;
1743 $cfg ->{ $key } = $value ;
1745 warn "ignore config line: $line\n "
1750 check_prop
( $cfg, $schema, '' , $errors );
1752 foreach my $k ( keys %$errors ) {
1753 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1760 # generate simple key/value file
1762 my ( $schema, $filename, $cfg ) = @_ ;
1764 # do fast check (avoid validate_schema($schema))
1765 die "got strange schema" if ! $schema ->{ type
} ||
1766 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1768 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1772 foreach my $k ( sort keys %$cfg ) {
1773 $data .= " $k : $cfg ->{ $k } \n " ;
1779 # helpers used to generate our manual pages
1781 my $find_schema_default_key = sub {
1785 my $keyAliasProps = {};
1787 foreach my $key ( keys %$format ) {
1788 my $phash = $format ->{ $key };
1789 if ( $phash ->{ default_key
}) {
1790 die "multiple default keys in schema ( $default_key, $key ) \n "
1791 if defined ( $default_key );
1792 die "default key ' $key ' is an alias - this is not allowed \n "
1793 if defined ( $phash ->{ alias
});
1794 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1795 if $phash ->{ keyAlias
};
1796 $default_key = $key ;
1798 my $key_alias = $phash ->{ keyAlias
};
1799 die "found keyAlias without 'alias definition for ' $key ' \n "
1800 if $key_alias && ! $phash ->{ alias
};
1802 if ( $phash ->{ alias
} && $key_alias ) {
1803 die "inconsistent keyAlias ' $key_alias ' definition"
1804 if defined ( $keyAliasProps ->{ $key_alias }) &&
1805 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1806 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1810 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1813 sub generate_typetext
{
1814 my ( $format, $list_enums ) = @_ ;
1816 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1821 my $add_option_string = sub {
1822 my ( $text, $optional ) = @_ ;
1828 $text = "[ $text ]" if $optional ;
1833 my $format_key_value = sub {
1834 my ( $key, $phash ) = @_ ;
1836 die "internal error" if defined ( $phash ->{ alias
});
1842 if ( my $desc = $phash ->{ format_description
}) {
1843 $typetext .= "< $desc >" ;
1844 } elsif ( my $text = $phash ->{ typetext
}) {
1846 } elsif ( my $enum = $phash ->{ enum
}) {
1847 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1848 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1850 $typetext .= '<enum>' ;
1852 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1853 $typetext .= '<1|0>' ;
1854 } elsif ( $phash ->{ type
} eq 'integer' ) {
1855 $typetext .= '<integer>' ;
1856 } elsif ( $phash ->{ type
} eq 'number' ) {
1857 $typetext .= '<number>' ;
1859 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1862 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1863 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1865 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1871 my $cond_add_key = sub {
1874 return if $done ->{ $key }; # avoid duplicates
1878 my $phash = $format ->{ $key };
1880 return if ! $phash ; # should not happen
1882 return if $phash ->{ alias
};
1884 & $format_key_value ( $key, $phash );
1888 & $cond_add_key ( $default_key ) if defined ( $default_key );
1890 # add required keys first
1891 foreach my $key ( sort keys %$format ) {
1892 my $phash = $format ->{ $key };
1893 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1897 foreach my $key ( sort keys %$format ) {
1898 & $cond_add_key ( $key );
1901 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1902 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1908 sub print_property_string
{
1909 my ( $data, $format, $skip, $path ) = @_ ;
1912 if ( ref ( $format ) ne 'HASH' ) {
1913 my $schema = get_format
( $format );
1914 die "not a valid format: $format\n " if ! $schema ;
1915 # named formats can have validators attached
1916 $validator = $format_validators ->{ $format };
1921 check_object
( $path, $format, $data, undef , $errors );
1922 if ( scalar ( %$errors )) {
1923 raise
"format error" , errors
=> $errors ;
1926 $data = $validator ->( $data ) if $validator ;
1928 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1933 my $add_option_string = sub {
1936 $res .= ',' if $add_sep ;
1941 my $format_value = sub {
1942 my ( $key, $value, $format ) = @_ ;
1944 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1945 return format_size
( $value );
1947 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1952 my $done = { map { $_ => 1 } @$skip };
1954 my $cond_add_key = sub {
1955 my ( $key, $isdefault ) = @_ ;
1957 return if $done ->{ $key }; # avoid duplicates
1961 my $value = $data ->{ $key };
1963 return if ! defined ( $value );
1965 my $phash = $format ->{ $key };
1967 # try to combine values if we have key aliases
1968 if ( my $combine = $keyAliasProps ->{ $key }) {
1969 if ( defined ( my $combine_value = $data ->{ $combine })) {
1970 my $combine_format = $format ->{ $combine }->{ format
};
1971 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1972 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1973 & $add_option_string ( "${value_str}=${combine_str}" );
1974 $done ->{ $combine } = 1 ;
1979 if ( $phash && $phash ->{ alias
}) {
1980 $phash = $format ->{ $phash ->{ alias
}};
1983 die "invalid key ' $key ' \n " if ! $phash ;
1984 die "internal error" if defined ( $phash ->{ alias
});
1986 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1988 & $add_option_string ( $value_str );
1990 & $add_option_string ( " $key =${value_str}" );
1994 # add default key first
1995 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1997 # add required keys first
1998 foreach my $key ( sort keys %$data ) {
1999 my $phash = $format ->{ $key };
2000 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
2004 foreach my $key ( sort keys %$data ) {
2005 & $cond_add_key ( $key );
2011 sub schema_get_type_text
{
2012 my ( $phash, $style ) = @_ ;
2014 my $type = $phash ->{ type
} || 'string' ;
2016 if ( $phash ->{ typetext
}) {
2017 return $phash ->{ typetext
};
2018 } elsif ( $phash ->{ format_description
}) {
2019 return "< $phash ->{format_description}>" ;
2020 } elsif ( $phash ->{ enum
}) {
2021 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
2022 } elsif ( $phash ->{ pattern
}) {
2023 return $phash ->{ pattern
};
2024 } elsif ( $type eq 'integer' || $type eq 'number' ) {
2025 # NOTE: always access values as number (avoid converion to string)
2026 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
2027 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
2028 ( $phash ->{ maximum
} + 0 ) . ")" ;
2029 } elsif ( defined ( $phash ->{ minimum
})) {
2030 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
2031 } elsif ( defined ( $phash ->{ maximum
})) {
2032 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
2034 } elsif ( $type eq 'string' ) {
2035 if ( my $format = $phash ->{ format
}) {
2036 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
2037 if ( ref ( $format ) eq 'HASH' ) {
2039 $list_enums = 1 if $style && $style eq 'config-sub' ;
2040 return generate_typetext
( $format, $list_enums );