]>
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 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
25 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
26 # see: http://json-schema.org/
28 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
30 my $standard_options = {};
31 sub register_standard_option
{
32 my ( $name, $schema ) = @_ ;
34 die "standard option ' $name ' already registered \n "
35 if $standard_options ->{ $name };
37 $standard_options ->{ $name } = $schema ;
40 sub get_standard_option
{
41 my ( $name, $base ) = @_ ;
43 my $std = $standard_options ->{ $name };
44 die "no such standard option ' $name ' \n " if ! $std ;
46 my $res = $base || {};
48 foreach my $opt ( keys %$std ) {
49 next if defined ( $res ->{ $opt });
50 $res ->{ $opt } = $std ->{ $opt };
56 register_standard_option
( 'pve-vmid' , {
57 description
=> "The (unique) ID of the VM." ,
58 type
=> 'integer' , format
=> 'pve-vmid' ,
62 register_standard_option
( 'pve-node' , {
63 description
=> "The cluster node name." ,
64 type
=> 'string' , format
=> 'pve-node' ,
67 register_standard_option
( 'pve-node-list' , {
68 description
=> "List of cluster node names." ,
69 type
=> 'string' , format
=> 'pve-node-list' ,
72 register_standard_option
( 'pve-iface' , {
73 description
=> "Network interface name." ,
74 type
=> 'string' , format
=> 'pve-iface' ,
75 minLength
=> 2 , maxLength
=> 20 ,
78 register_standard_option
( 'pve-storage-id' , {
79 description
=> "The storage identifier." ,
80 type
=> 'string' , format
=> 'pve-storage-id' ,
83 register_standard_option
( 'pve-config-digest' , {
84 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.' ,
87 maxLength
=> 40 , # sha1 hex digest length is 40
90 register_standard_option
( 'skiplock' , {
91 description
=> "Ignore locks - only root is allowed to use this option." ,
96 register_standard_option
( 'extra-args' , {
97 description
=> "Extra arguments as array" ,
99 items
=> { type
=> 'string' },
103 register_standard_option
( 'fingerprint-sha256' , {
104 description
=> "Certificate SHA 256 fingerprint." ,
106 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}' ,
109 register_standard_option
( 'pve-output-format' , {
111 description
=> 'Output format.' ,
112 enum
=> [ 'text' , 'json' , 'json-pretty' , 'yaml' ],
117 register_standard_option
( 'pve-snapshot-name' , {
118 description
=> "The name of the snapshot." ,
119 type
=> 'string' , format
=> 'pve-configid' ,
123 my $format_list = {};
124 my $format_validators = {};
126 sub register_format
{
127 my ( $name, $format, $validator ) = @_ ;
129 die "JSON schema format ' $name ' already registered \n "
130 if $format_list ->{ $name };
133 die "A \ $validator function can only be specified for hash-based formats \n "
134 if ref ( $format ) ne 'HASH' ;
135 $format_validators ->{ $name } = $validator ;
138 $format_list ->{ $name } = $format ;
143 return $format_list ->{ $name };
146 my $renderer_hash = {};
148 sub register_renderer
{
149 my ( $name, $code ) = @_ ;
151 die "renderer ' $name ' already registered \n "
152 if $renderer_hash ->{ $name };
154 $renderer_hash ->{ $name } = $code ;
159 return $renderer_hash ->{ $name };
162 # register some common type for pve
164 register_format
( 'string' , sub {}); # allow format => 'string-list'
166 register_format
( 'urlencoded' , \
& pve_verify_urlencoded
);
167 sub pve_verify_urlencoded
{
168 my ( $text, $noerr ) = @_ ;
169 if ( $text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/ ) {
170 return undef if $noerr ;
171 die "invalid urlencoded string: $text\n " ;
176 register_format
( 'pve-configid' , \
& pve_verify_configid
);
177 sub pve_verify_configid
{
178 my ( $id, $noerr ) = @_ ;
180 if ( $id !~ m/^[a-z][a-z0-9_-]+$/i ) {
181 return undef if $noerr ;
182 die "invalid configuration ID ' $id ' \n " ;
187 PVE
:: JSONSchema
:: register_format
( 'pve-storage-id' , \
& parse_storage_id
);
188 sub parse_storage_id
{
189 my ( $storeid, $noerr ) = @_ ;
191 return parse_id
( $storeid, 'storage' , $noerr );
194 PVE
:: JSONSchema
:: register_format
( 'acme-plugin-id' , \
& parse_acme_plugin_id
);
195 sub parse_acme_plugin_id
{
196 my ( $pluginid, $noerr ) = @_ ;
198 return parse_id
( $pluginid, 'ACME plugin' , $noerr );
202 my ( $id, $type, $noerr ) = @_ ;
204 if ( $id !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
205 return undef if $noerr ;
206 die " $type ID ' $id ' contains illegal characters \n " ;
211 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
212 sub pve_verify_vmid
{
213 my ( $vmid, $noerr ) = @_ ;
215 if ( $vmid !~ m/^[1-9][0-9]{2,8}$/ ) {
216 return undef if $noerr ;
217 die "value does not look like a valid VM ID \n " ;
222 register_format
( 'pve-node' , \
& pve_verify_node_name
);
223 sub pve_verify_node_name
{
224 my ( $node, $noerr ) = @_ ;
226 if ( $node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/ ) {
227 return undef if $noerr ;
228 die "value does not look like a valid node name \n " ;
234 my ( $idmap, $idformat ) = @_ ;
236 return undef if ! $idmap ;
240 foreach my $entry ( PVE
:: Tools
:: split_list
( $idmap )) {
242 $map ->{ identity
} = 1 ;
243 } elsif ( $entry =~ m/^([^:]+):([^:]+)$/ ) {
244 my ( $source, $target ) = ( $1, $2 );
246 check_format
( $idformat, $source, '' );
247 check_format
( $idformat, $target, '' );
249 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
251 die "duplicate mapping for source ' $source ' \n "
252 if exists $map ->{ entries
}->{ $source };
254 $map ->{ entries
}->{ $source } = $target ;
257 check_format
( $idformat, $entry );
259 die "entry ' $entry ' contains invalid ID - $@\n " if $@ ;
261 die "default target ID can only be provided once \n "
262 if exists $map ->{ default };
264 $map ->{ default } = $entry ;
268 die "identity mapping cannot be combined with other mappings \n "
269 if $map ->{ identity
} && ( $map ->{ default } || exists $map ->{ entries
});
274 register_format
( 'storagepair' , \
& verify_storagepair
);
275 sub verify_storagepair
{
276 my ( $storagepair, $noerr ) = @_ ;
278 # note: this only checks a single list entry
279 # when using a storagepair-list map, you need to pass the full
280 # parameter to parse_idmap
281 eval { parse_idmap
( $storagepair, 'pve-storage-id' ) };
283 return undef if $noerr ;
290 register_format
( 'mac-addr' , \
& pve_verify_mac_addr
);
291 sub pve_verify_mac_addr
{
292 my ( $mac_addr, $noerr ) = @_ ;
294 # don't allow I/G bit to be set, most of the time it breaks things, see:
295 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
296 if ( $mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i ) {
297 return undef if $noerr ;
298 die "value does not look like a valid unicast MAC address \n " ;
303 register_standard_option
( 'mac-addr' , {
305 description
=> 'Unicast MAC address.' ,
306 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.' ,
307 format_description
=> "XX:XX:XX:XX:XX:XX" ,
309 format
=> 'mac-addr' ,
312 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
313 sub pve_verify_ipv4
{
314 my ( $ipv4, $noerr ) = @_ ;
316 if ( $ipv4 !~ m/^(?:$IPV4RE)$/ ) {
317 return undef if $noerr ;
318 die "value does not look like a valid IPv4 address \n " ;
323 register_format
( 'ipv6' , \
& pve_verify_ipv6
);
324 sub pve_verify_ipv6
{
325 my ( $ipv6, $noerr ) = @_ ;
327 if ( $ipv6 !~ m/^(?:$IPV6RE)$/ ) {
328 return undef if $noerr ;
329 die "value does not look like a valid IPv6 address \n " ;
334 register_format
( 'ip' , \
& pve_verify_ip
);
336 my ( $ip, $noerr ) = @_ ;
338 if ( $ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/ ) {
339 return undef if $noerr ;
340 die "value does not look like a valid IP address \n " ;
345 PVE
:: JSONSchema
:: register_format
( 'ldap-simple-attr' , \
& verify_ldap_simple_attr
);
346 sub verify_ldap_simple_attr
{
347 my ( $attr, $noerr ) = @_ ;
349 if ( $attr =~ m/^[a-zA-Z0-9]+$/ ) {
353 die "value ' $attr ' does not look like a simple ldap attribute name \n " if ! $noerr ;
358 my $ipv4_mask_hash = {
376 '255.255.128.0' => 17 ,
377 '255.255.192.0' => 18 ,
378 '255.255.224.0' => 19 ,
379 '255.255.240.0' => 20 ,
380 '255.255.248.0' => 21 ,
381 '255.255.252.0' => 22 ,
382 '255.255.254.0' => 23 ,
383 '255.255.255.0' => 24 ,
384 '255.255.255.128' => 25 ,
385 '255.255.255.192' => 26 ,
386 '255.255.255.224' => 27 ,
387 '255.255.255.240' => 28 ,
388 '255.255.255.248' => 29 ,
389 '255.255.255.252' => 30 ,
390 '255.255.255.254' => 31 ,
391 '255.255.255.255' => 32 ,
394 sub get_netmask_bits
{
396 return $ipv4_mask_hash ->{ $mask };
399 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
400 sub pve_verify_ipv4mask
{
401 my ( $mask, $noerr ) = @_ ;
403 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
404 return undef if $noerr ;
405 die "value does not look like a valid IP netmask \n " ;
410 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
411 sub pve_verify_cidrv6
{
412 my ( $cidr, $noerr ) = @_ ;
414 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
418 return undef if $noerr ;
419 die "value does not look like a valid IPv6 CIDR network \n " ;
422 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
423 sub pve_verify_cidrv4
{
424 my ( $cidr, $noerr ) = @_ ;
426 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
430 return undef if $noerr ;
431 die "value does not look like a valid IPv4 CIDR network \n " ;
434 register_format
( 'CIDR' , \
& pve_verify_cidr
);
435 sub pve_verify_cidr
{
436 my ( $cidr, $noerr ) = @_ ;
438 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
439 pve_verify_cidrv6
( $cidr, 1 )))
441 return undef if $noerr ;
442 die "value does not look like a valid CIDR network \n " ;
448 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
449 sub pve_verify_ipv4_config
{
450 my ( $config, $noerr ) = @_ ;
452 return $config if $config =~ /^(?:dhcp|manual)$/ ||
453 pve_verify_cidrv4
( $config, 1 );
454 return undef if $noerr ;
455 die "value does not look like a valid ipv4 network configuration \n " ;
458 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
459 sub pve_verify_ipv6_config
{
460 my ( $config, $noerr ) = @_ ;
462 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
463 pve_verify_cidrv6
( $config, 1 );
464 return undef if $noerr ;
465 die "value does not look like a valid ipv6 network configuration \n " ;
468 register_format
( 'email' , \
& pve_verify_email
);
469 sub pve_verify_email
{
470 my ( $email, $noerr ) = @_ ;
472 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
473 return undef if $noerr ;
474 die "value does not look like a valid email address \n " ;
479 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
480 sub pve_verify_dns_name
{
481 my ( $name, $noerr ) = @_ ;
483 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
485 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
486 return undef if $noerr ;
487 die "value does not look like a valid DNS name \n " ;
492 register_format
( 'timezone' , \
& pve_verify_timezone
);
493 sub pve_verify_timezone
{
494 my ( $timezone, $noerr ) = @_ ;
496 return $timezone if $timezone eq 'UTC' ;
498 open ( my $fh, "<" , "/usr/share/zoneinfo/zone.tab" );
499 while ( my $line = < $fh >) {
500 next if $line =~ /^\s*#/ ;
502 my $zone = ( split /\t/ , $line )[ 2 ];
503 return $timezone if $timezone eq $zone ; # found
507 return undef if $noerr ;
508 die "invalid time zone ' $timezone ' \n " ;
511 # network interface name
512 register_format
( 'pve-iface' , \
& pve_verify_iface
);
513 sub pve_verify_iface
{
514 my ( $id, $noerr ) = @_ ;
516 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
517 return undef if $noerr ;
518 die "invalid network interface name ' $id ' \n " ;
523 # general addresses by name or IP
524 register_format
( 'address' , \
& pve_verify_address
);
525 sub pve_verify_address
{
526 my ( $addr, $noerr ) = @_ ;
528 if (!( pve_verify_ip
( $addr, 1 ) ||
529 pve_verify_dns_name
( $addr, 1 )))
531 return undef if $noerr ;
532 die "value does not look like a valid address: $addr\n " ;
537 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
538 sub pve_verify_disk_size
{
539 my ( $size, $noerr ) = @_ ;
540 if (! defined ( parse_size
( $size ))) {
541 return undef if $noerr ;
542 die "value does not look like a valid disk size: $size\n " ;
547 register_standard_option
( 'spice-proxy' , {
548 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)." ,
549 type
=> 'string' , format
=> 'address' ,
552 register_standard_option
( 'remote-viewer-config' , {
553 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
554 additionalProperties
=> 1 ,
556 type
=> { type
=> 'string' },
557 password
=> { type
=> 'string' },
558 proxy
=> { type
=> 'string' },
559 host
=> { type
=> 'string' },
560 'tls-port' => { type
=> 'integer' },
564 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
565 sub pve_verify_startup_order
{
566 my ( $value, $noerr ) = @_ ;
568 return $value if pve_parse_startup_order
( $value );
570 return undef if $noerr ;
572 die "unable to parse startup options \n " ;
577 type
=> 'number' , minimum
=> '0' ,
578 format_description
=> 'LIMIT' ,
581 my $bwlimit_format = {
584 description
=> 'default bandwidth limit in KiB/s' ,
588 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
592 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
596 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
600 description
=> 'bandwidth limit in KiB/s for moving disks' ,
603 register_format
( 'bwlimit' , $bwlimit_format );
604 register_standard_option
( 'bwlimit' , {
605 description
=> "Set bandwidth/io limits various operations." ,
608 format
=> $bwlimit_format,
611 # used for pve-tag-list in e.g., guest configs
612 register_format
( 'pve-tag' , \
& pve_verify_tag
);
614 my ( $value, $noerr ) = @_ ;
616 return $value if $value =~ m/^[a-z0-9_][a-z0-9_\-\+\.]*$/i ;
618 return undef if $noerr ;
620 die "invalid characters in tag \n " ;
623 sub pve_parse_startup_order
{
626 return undef if ! $value ;
630 foreach my $p ( split ( /,/ , $value )) {
631 next if $p =~ m/^\s*$/ ;
633 if ( $p =~ m/^(order=)?(\d+)$/ ) {
635 } elsif ( $p =~ m/^up=(\d+)$/ ) {
637 } elsif ( $p =~ m/^down=(\d+)$/ ) {
647 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
648 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." ,
650 type
=> 'string' , format
=> 'pve-startup-order' ,
651 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
654 register_format
( 'pve-tfa-secret' , \
& pve_verify_tfa_secret
);
655 sub pve_verify_tfa_secret
{
656 my ( $key, $noerr ) = @_ ;
658 # The old format used 16 base32 chars or 40 hex digits. Since they have a common subset it's
659 # hard to distinguish them without the our previous length constraints, so add a 'v2' of the
660 # format to support arbitrary lengths properly:
661 if ( $key =~ /^v2-0x[0-9a-fA-F]{16,128}$/ || # hex
662 $key =~ /^v2-[A-Z2-7=]{16,128}$/ || # base32
663 $key =~ /^(?:[A-Z2-7=]{16}|[A-Fa-f0-9]{40})$/ ) # and the old pattern copy&pasted
668 return undef if $noerr ;
670 die "unable to decode TFA secret \n " ;
674 my ( $format, $value, $path ) = @_ ;
676 if ( ref ( $format ) eq 'HASH' ) {
677 # hash ref cannot have validator/list/opt handling attached
678 return parse_property_string
( $format, $value, $path );
681 if ( ref ( $format ) eq 'CODE' ) {
682 # we are the (sole, old-style) validator
683 return $format ->( $value );
686 return if $format eq 'regex' ;
689 $format =~ m/^(.*?)(?:-a?(list|opt))?$/ ;
690 my ( $format_name, $format_type ) = ( $1, $2 // 'none' );
691 my $registered = get_format
( $format_name );
692 die "undefined format ' $format ' \n " if ! $registered ;
694 die "'- $format_type ' format must have code ref, not hash \n "
695 if $format_type ne 'none' && ref ( $registered ) ne 'CODE' ;
697 if ( $format_type eq 'list' ) {
698 # Note: we allow empty lists
699 foreach my $v ( split_list
( $value )) {
700 $parsed = $registered ->( $v );
702 } elsif ( $format_type eq 'opt' ) {
703 $parsed = $registered ->( $value ) if $value ;
705 if ( ref ( $registered ) eq 'HASH' ) {
706 # Note: this is the only case where a validator function could be
707 # attached, hence it's safe to handle that in parse_property_string.
708 # We do however have to call it with $format_name instead of
709 # $registered, so it knows about the name (and thus any validators).
710 $parsed = parse_property_string
( $format, $value, $path );
712 $parsed = $registered ->( $value );
722 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
723 my ( $size, $unit ) = ( $1, $3 );
726 $size = $size * 1024 ;
727 } elsif ( $unit eq 'M' ) {
728 $size = $size * 1024 * 1024 ;
729 } elsif ( $unit eq 'G' ) {
730 $size = $size * 1024 * 1024 * 1024 ;
731 } elsif ( $unit eq 'T' ) {
732 $size = $size * 1024 * 1024 * 1024 * 1024 ;
743 my $kb = int ( $size/1024 );
744 return $size if $kb*1024 != $size ;
746 my $mb = int ( $kb/1024 );
747 return "${kb}K" if $mb*1024 != $kb ;
749 my $gb = int ( $mb/1024 );
750 return "${mb}M" if $gb*1024 != $mb ;
752 my $tb = int ( $gb/1024 );
753 return "${gb}G" if $tb*1024 != $gb ;
760 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
761 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
765 sub parse_property_string
{
766 my ( $format, $data, $path, $additional_properties ) = @_ ;
768 # In property strings we default to not allowing additional properties
769 $additional_properties = 0 if ! defined ( $additional_properties );
771 # Support named formats here, too:
774 if ( my $reg = get_format
( $format )) {
775 die "parse_property_string only accepts hash based named formats \n "
776 if ref ( $reg ) ne 'HASH' ;
778 # named formats can have validators attached
779 $validator = $format_validators ->{ $format };
783 die "unknown format: $format\n " ;
785 } elsif ( ref ( $format ) ne 'HASH' ) {
786 die "unexpected format value of type " . ref ( $format ). " \n " ;
792 foreach my $part ( split ( /,/ , $data )) {
793 next if $part =~ /^\s*$/ ;
795 if ( $part =~ /^([^=]+)=(.+)$/ ) {
796 my ( $k, $v ) = ( $1, $2 );
797 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
798 my $schema = $format ->{ $k };
799 if ( my $alias = $schema ->{ alias
}) {
800 if ( my $key_alias = $schema ->{ keyAlias
}) {
801 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
802 $res ->{ $key_alias } = $k ;
805 $schema = $format ->{ $k };
808 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
809 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
810 $v = parse_boolean
( $v ) // $v ;
813 } elsif ( $part !~ /=/ ) {
814 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
815 foreach my $key ( keys %$format ) {
816 if ( $format ->{ $key }->{ default_key
}) {
818 if (! $res ->{ $default_key }) {
819 $res ->{ $default_key } = $part ;
822 die "duplicate key in comma-separated list property: $default_key\n " ;
825 die "value without key, but schema does not define a default key \n " if ! $default_key ;
827 die "missing key in comma-separated list property \n " ;
832 check_object
( $path, $format, $res, $additional_properties, $errors );
833 if ( scalar ( %$errors )) {
834 raise
"format error \n " , errors
=> $errors ;
837 return $validator ->( $res ) if $validator ;
842 my ( $errors, $path, $msg ) = @_ ;
844 $path = '_root' if ! $path ;
846 if ( $errors ->{ $path }) {
847 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
849 $errors ->{ $path } = $msg ;
856 # see 'man perlretut'
857 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
863 return $value =~ m/^[+-]?\d+$/ ;
867 my ( $path, $type, $value, $errors ) = @_ ;
871 if (! defined ( $value )) {
872 return 1 if $type eq 'null' ;
876 if ( my $tt = ref ( $type )) {
877 if ( $tt eq 'ARRAY' ) {
878 foreach my $t ( @$type ) {
880 check_type
( $path, $t, $value, $tmperr );
881 return 1 if ! scalar ( %$tmperr );
883 my $ttext = join ( '|' , @$type );
884 add_error
( $errors, $path, "type check (' $ttext ') failed" );
886 } elsif ( $tt eq 'HASH' ) {
888 check_prop
( $value, $type, $path, $tmperr );
889 return 1 if ! scalar ( %$tmperr );
890 add_error
( $errors, $path, "type check failed" );
893 die "internal error - got reference type ' $tt '" ;
898 return 1 if $type eq 'any' ;
900 if ( $type eq 'null' ) {
901 if ( defined ( $value )) {
902 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
908 my $vt = ref ( $value );
910 if ( $type eq 'array' ) {
911 if (! $vt || $vt ne 'ARRAY' ) {
912 add_error
( $errors, $path, "type check (' $type ') failed" );
916 } elsif ( $type eq 'object' ) {
917 if (! $vt || $vt ne 'HASH' ) {
918 add_error
( $errors, $path, "type check (' $type ') failed" );
922 } elsif ( $type eq 'coderef' ) {
923 if (! $vt || $vt ne 'CODE' ) {
924 add_error
( $errors, $path, "type check (' $type ') failed" );
928 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
929 # qr// regexes can be used as strings and make sense for format=regex
933 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
936 if ( $type eq 'string' ) {
937 return 1 ; # nothing to check ?
938 } elsif ( $type eq 'boolean' ) {
939 #if ($value =~ m/^(1|true|yes|on)$/i) {
942 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
943 } elsif ( $value eq '0' ) {
944 return 1 ; # return success (not value)
946 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
949 } elsif ( $type eq 'integer' ) {
950 if (! is_integer
( $value )) {
951 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
955 } elsif ( $type eq 'number' ) {
956 if (! is_number
( $value )) {
957 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
962 return 1 ; # no need to verify unknown types
972 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
974 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
976 my $st = ref ( $schema );
977 if (! $st || $st ne 'HASH' ) {
978 add_error
( $errors, $path, "Invalid schema definition." );
982 my $vt = ref ( $value );
983 if (! $vt || $vt ne 'HASH' ) {
984 add_error
( $errors, $path, "an object is required" );
988 foreach my $k ( keys %$schema ) {
989 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
992 foreach my $k ( keys %$value ) {
994 my $newpath = $path ?
" $path . $k " : $k ;
996 if ( my $subschema = $schema ->{ $k }) {
997 if ( my $requires = $subschema ->{ requires
}) {
998 if ( ref ( $requires )) {
999 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
1000 check_prop
( $value, $requires, $path, $errors );
1001 } elsif (! defined ( $value ->{ $requires })) {
1002 add_error
( $errors, $path ?
" $path . $requires " : $requires,
1003 "missing property - ' $newpath ' requires this property" );
1007 next ; # value is already checked above
1010 if ( defined ( $additional_properties ) && ! $additional_properties ) {
1011 add_error
( $errors, $newpath, "property is not defined in schema " .
1012 "and the schema does not allow additional properties" );
1015 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
1016 if ref ( $additional_properties );
1020 sub check_object_warn
{
1021 my ( $path, $schema, $value, $additional_properties ) = @_ ;
1023 check_object
( $path, $schema, $value, $additional_properties, $errors );
1024 if ( scalar ( %$errors )) {
1025 foreach my $k ( keys %$errors ) {
1026 warn "parse error: $k : $errors ->{ $k } \n " ;
1034 my ( $value, $schema, $path, $errors ) = @_ ;
1036 die "internal error - no schema" if ! $schema ;
1037 die "internal error" if ! $errors ;
1039 #print "check_prop $path\n" if $value;
1041 my $st = ref ( $schema );
1042 if (! $st || $st ne 'HASH' ) {
1043 add_error
( $errors, $path, "Invalid schema definition." );
1047 # if it extends another schema, it must pass that schema as well
1048 if ( $schema ->{ extends
}) {
1049 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
1052 if (! defined ( $value )) {
1053 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
1054 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
1055 add_error
( $errors, $path, "property is missing and it is not optional" );
1060 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
1062 if ( $schema ->{ disallow
}) {
1064 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
1065 add_error
( $errors, $path, "disallowed value was matched" );
1070 if ( my $vt = ref ( $value )) {
1072 if ( $vt eq 'ARRAY' ) {
1073 if ( $schema ->{ items
}) {
1074 my $it = ref ( $schema ->{ items
});
1075 if ( $it && $it eq 'ARRAY' ) {
1076 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
1077 die "not implemented" ;
1080 foreach my $el ( @$value ) {
1081 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
1087 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
1088 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
1089 $value, $schema ->{ additionalProperties
}, $errors );
1095 if ( my $format = $schema ->{ format
}) {
1096 eval { check_format
( $format, $value, $path ); };
1098 add_error
( $errors, $path, "invalid format - $@ " );
1103 if ( my $pattern = $schema ->{ pattern
}) {
1104 if ( $value !~ m/^$pattern$/ ) {
1105 add_error
( $errors, $path, "value does not match the regex pattern" );
1110 if ( defined ( my $max = $schema ->{ maxLength
})) {
1111 if ( length ( $value ) > $max ) {
1112 add_error
( $errors, $path, "value may only be $max characters long" );
1117 if ( defined ( my $min = $schema ->{ minLength
})) {
1118 if ( length ( $value ) < $min ) {
1119 add_error
( $errors, $path, "value must be at least $min characters long" );
1124 if ( is_number
( $value )) {
1125 if ( defined ( my $max = $schema ->{ maximum
})) {
1126 if ( $value > $max ) {
1127 add_error
( $errors, $path, "value must have a maximum value of $max " );
1132 if ( defined ( my $min = $schema ->{ minimum
})) {
1133 if ( $value < $min ) {
1134 add_error
( $errors, $path, "value must have a minimum value of $min " );
1140 if ( my $ea = $schema ->{ enum
}) {
1143 foreach my $ev ( @$ea ) {
1144 if ( $ev eq $value ) {
1150 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
1151 join ( ", " , @$ea ) . "'" );
1158 my ( $instance, $schema, $errmsg ) = @_ ;
1161 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1163 # todo: cycle detection is only needed for debugging, I guess
1164 # we can disable that in the final release
1165 # todo: is there a better/faster way to detect cycles?
1167 find_cycle
( $instance, sub { $cycles = 1 });
1169 add_error
( $errors, undef , "data structure contains recursive cycles" );
1171 check_prop
( $instance, $schema, '' , $errors );
1174 if ( scalar ( %$errors )) {
1175 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1181 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1182 my $default_schema_noref = {
1183 description
=> "This is the JSON Schema for JSON Schemas." ,
1184 type
=> [ "object" ],
1185 additionalProperties
=> 0 ,
1188 type
=> [ "string" , "array" ],
1189 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1194 enum
=> $schema_valid_types,
1196 enum
=> $schema_valid_types,
1200 description
=> "This indicates that the instance property in the instance object is not required." ,
1206 description
=> "This is a definition for the properties of an object value" ,
1212 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1216 additionalProperties
=> {
1217 type
=> [ "boolean" , "object" ],
1218 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1225 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1230 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1234 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1241 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1247 description
=> "A text representation of the type (used to generate documentation)." ,
1252 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." ,
1259 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1264 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)." ,
1266 verbose_description
=> {
1269 description
=> "This provides a more verbose description." ,
1271 format_description
=> {
1274 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1279 description
=> "This provides the title of the property" ,
1284 description
=> "This is used to provide rendering hints to format cli command output." ,
1287 type
=> [ "string" , "object" ],
1289 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1292 type
=> [ "string" , "object" ],
1294 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" ,
1299 description
=> "Whether this is the default key in a comma separated list property string." ,
1304 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." ,
1309 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1310 requires
=> 'alias' ,
1315 description
=> "This indicates the default for the instance property."
1319 description
=> "Bash completion function. This function should return a list of possible values." ,
1325 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." ,
1330 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1333 # this is from hyper schema
1336 description
=> "This defines the link relations of the instance objects" ,
1343 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" ,
1347 description
=> "This is the name of the link relation" ,
1353 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1362 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1368 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1370 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1371 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1373 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1374 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1376 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1377 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1379 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1380 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1382 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1383 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1385 my $method_schema = {
1387 additionalProperties
=> 0 ,
1390 description
=> "This a description of the method" ,
1395 description
=> "This indicates the name of the function to call." ,
1398 additionalProperties
=> 1 ,
1413 description
=> "The HTTP method name." ,
1414 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1419 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1424 description
=> "Method is available for clients authenticated using an API token." ,
1430 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1435 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1438 proxyto_callback
=> {
1440 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1445 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1447 additionalProperties
=> 0 ,
1450 description
=> "Describe access permissions." ,
1454 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1456 enum
=> [ 'all' , 'world' ],
1460 description
=> "Array of permission checks (prefix notation)." ,
1467 description
=> "Used internally" ,
1471 description
=> "Used internally" ,
1476 description
=> "path for URL matching (uri template)" ,
1478 fragmentDelimiter
=> {
1480 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." ,
1485 description
=> "JSON Schema for parameters." ,
1490 description
=> "JSON Schema for return value." ,
1495 description
=> "method implementation (code reference)" ,
1500 description
=> "Delegate call to this class (perl class string)." ,
1503 additionalProperties
=> 0 ,
1509 fragmentDelimiter
=> { optional
=> 1 }
1517 sub validate_schema
{
1520 my $errmsg = "internal error - unable to verify schema \n " ;
1521 validate
( $schema, $default_schema, $errmsg );
1524 sub validate_method_info
{
1527 my $errmsg = "internal error - unable to verify method info \n " ;
1528 validate
( $info, $method_schema, $errmsg );
1530 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1531 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1534 # run a self test on load
1535 # make sure we can verify the default schema
1536 validate_schema
( $default_schema_noref );
1537 validate_schema
( $method_schema );
1539 # and now some utility methods (used by pve api)
1540 sub method_get_child_link
{
1543 return undef if ! $info ;
1545 my $schema = $info ->{ returns
};
1546 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1548 my $links = $schema ->{ links
};
1549 return undef if ! $links ;
1552 foreach my $lnk ( @$links ) {
1553 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1562 # a way to parse command line parameters, using a
1563 # schema to configure Getopt::Long
1565 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1567 if (! $schema || ! $schema ->{ properties
}) {
1568 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1569 if scalar ( @$args ) != 0 ;
1574 if ( $arg_param && ! ref ( $arg_param )) {
1575 my $pd = $schema ->{ properties
}->{ $arg_param };
1576 die "expected list format $pd ->{format}"
1577 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1578 $list_param = $arg_param ;
1581 my @interactive = ();
1583 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1584 my $pd = $schema ->{ properties
}->{ $prop };
1585 next if $list_param && $prop eq $list_param ;
1586 next if defined ( $fixed_param ->{ $prop });
1588 my $mapping = $param_mapping_hash ->{ $prop };
1589 if ( $mapping && $mapping ->{ interactive
}) {
1590 # interactive parameters such as passwords: make the argument
1591 # optional and call the mapping function afterwards.
1592 push @getopt, " $prop :s" ;
1593 push @interactive, [ $prop, $mapping ->{ func
}];
1594 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1595 push @getopt, " $prop :s" ;
1597 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1598 push @getopt, " $prop =s@" ;
1600 push @getopt, " $prop =s" ;
1605 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1608 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1609 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1613 $opts ->{ $list_param } = $args ;
1615 } elsif ( ref ( $arg_param )) {
1616 foreach my $arg_name ( @$arg_param ) {
1617 if ( $opts ->{ 'extra-args' }) {
1618 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1620 if ( $arg_name eq 'extra-args' ) {
1621 $opts ->{ 'extra-args' } = $args ;
1625 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1626 $opts ->{ $arg_name } = shift @$args ;
1628 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1630 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1631 if scalar ( @$args ) != 0 ;
1634 if ( ref ( $arg_param )) {
1635 foreach my $arg_name ( @$arg_param ) {
1636 if ( $arg_name eq 'extra-args' ) {
1637 $opts ->{ 'extra-args' } = [];
1639 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1645 foreach my $entry ( @interactive ) {
1646 my ( $opt, $func ) = @$entry ;
1647 my $pd = $schema ->{ properties
}->{ $opt };
1648 my $value = $opts ->{ $opt };
1649 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1650 $opts ->{ $opt } = $func ->( $value );
1654 # decode after Getopt as we are not sure how well it handles unicode
1655 foreach my $p ( keys %$opts ) {
1656 if (! ref ( $opts ->{ $p })) {
1657 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1658 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1660 foreach my $v (@{ $opts ->{ $p }}) {
1661 push @$tmp, decode
( 'locale' , $v );
1664 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1665 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1667 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1671 foreach my $p ( keys %$opts ) {
1672 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1673 if ( $pd ->{ type
} eq 'boolean' ) {
1674 if ( $opts ->{ $p } eq '' ) {
1676 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1677 $opts ->{ $p } = $bool ;
1679 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1681 } elsif ( $pd ->{ format
}) {
1683 if ( $pd ->{ format
} =~ m/-list/ ) {
1684 # allow --vmid 100 --vmid 101 and --vmid 100,101
1685 # allow --dow mon --dow fri and --dow mon,fri
1686 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1687 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1688 # we encode array as \0 separated strings
1689 # Note: CGI.pm also use this encoding
1690 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1691 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1693 # st that split_list knows it is \0 terminated
1694 my $v = $opts ->{ $p }->[ 0 ];
1695 $opts ->{ $p } = " $v\0 " ;
1702 foreach my $p ( keys %$fixed_param ) {
1703 $opts ->{ $p } = $fixed_param ->{ $p };
1709 # A way to parse configuration data by giving a json schema
1711 my ( $schema, $filename, $raw ) = @_ ;
1713 # do fast check (avoid validate_schema($schema))
1714 die "got strange schema" if ! $schema ->{ type
} ||
1715 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1719 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1722 next if $line =~ /^#/ ;
1724 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1727 if ( $schema ->{ properties
}->{ $key } &&
1728 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1730 $value = parse_boolean
( $value ) // $value ;
1732 $cfg ->{ $key } = $value ;
1734 warn "ignore config line: $line\n "
1739 check_prop
( $cfg, $schema, '' , $errors );
1741 foreach my $k ( keys %$errors ) {
1742 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1749 # generate simple key/value file
1751 my ( $schema, $filename, $cfg ) = @_ ;
1753 # do fast check (avoid validate_schema($schema))
1754 die "got strange schema" if ! $schema ->{ type
} ||
1755 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1757 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1761 foreach my $k ( sort keys %$cfg ) {
1762 $data .= " $k : $cfg ->{ $k } \n " ;
1768 # helpers used to generate our manual pages
1770 my $find_schema_default_key = sub {
1774 my $keyAliasProps = {};
1776 foreach my $key ( keys %$format ) {
1777 my $phash = $format ->{ $key };
1778 if ( $phash ->{ default_key
}) {
1779 die "multiple default keys in schema ( $default_key, $key ) \n "
1780 if defined ( $default_key );
1781 die "default key ' $key ' is an alias - this is not allowed \n "
1782 if defined ( $phash ->{ alias
});
1783 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1784 if $phash ->{ keyAlias
};
1785 $default_key = $key ;
1787 my $key_alias = $phash ->{ keyAlias
};
1788 die "found keyAlias without 'alias definition for ' $key ' \n "
1789 if $key_alias && ! $phash ->{ alias
};
1791 if ( $phash ->{ alias
} && $key_alias ) {
1792 die "inconsistent keyAlias ' $key_alias ' definition"
1793 if defined ( $keyAliasProps ->{ $key_alias }) &&
1794 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1795 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1799 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1802 sub generate_typetext
{
1803 my ( $format, $list_enums ) = @_ ;
1805 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1810 my $add_option_string = sub {
1811 my ( $text, $optional ) = @_ ;
1817 $text = "[ $text ]" if $optional ;
1822 my $format_key_value = sub {
1823 my ( $key, $phash ) = @_ ;
1825 die "internal error" if defined ( $phash ->{ alias
});
1831 if ( my $desc = $phash ->{ format_description
}) {
1832 $typetext .= "< $desc >" ;
1833 } elsif ( my $text = $phash ->{ typetext
}) {
1835 } elsif ( my $enum = $phash ->{ enum
}) {
1836 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1837 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1839 $typetext .= '<enum>' ;
1841 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1842 $typetext .= '<1|0>' ;
1843 } elsif ( $phash ->{ type
} eq 'integer' ) {
1844 $typetext .= '<integer>' ;
1845 } elsif ( $phash ->{ type
} eq 'number' ) {
1846 $typetext .= '<number>' ;
1848 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1851 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1852 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1854 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1860 my $cond_add_key = sub {
1863 return if $done ->{ $key }; # avoid duplicates
1867 my $phash = $format ->{ $key };
1869 return if ! $phash ; # should not happen
1871 return if $phash ->{ alias
};
1873 & $format_key_value ( $key, $phash );
1877 & $cond_add_key ( $default_key ) if defined ( $default_key );
1879 # add required keys first
1880 foreach my $key ( sort keys %$format ) {
1881 my $phash = $format ->{ $key };
1882 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1886 foreach my $key ( sort keys %$format ) {
1887 & $cond_add_key ( $key );
1890 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1891 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1897 sub print_property_string
{
1898 my ( $data, $format, $skip, $path ) = @_ ;
1901 if ( ref ( $format ) ne 'HASH' ) {
1902 my $schema = get_format
( $format );
1903 die "not a valid format: $format\n " if ! $schema ;
1904 # named formats can have validators attached
1905 $validator = $format_validators ->{ $format };
1910 check_object
( $path, $format, $data, undef , $errors );
1911 if ( scalar ( %$errors )) {
1912 raise
"format error" , errors
=> $errors ;
1915 $data = $validator ->( $data ) if $validator ;
1917 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1922 my $add_option_string = sub {
1925 $res .= ',' if $add_sep ;
1930 my $format_value = sub {
1931 my ( $key, $value, $format ) = @_ ;
1933 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1934 return format_size
( $value );
1936 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1941 my $done = { map { $_ => 1 } @$skip };
1943 my $cond_add_key = sub {
1944 my ( $key, $isdefault ) = @_ ;
1946 return if $done ->{ $key }; # avoid duplicates
1950 my $value = $data ->{ $key };
1952 return if ! defined ( $value );
1954 my $phash = $format ->{ $key };
1956 # try to combine values if we have key aliases
1957 if ( my $combine = $keyAliasProps ->{ $key }) {
1958 if ( defined ( my $combine_value = $data ->{ $combine })) {
1959 my $combine_format = $format ->{ $combine }->{ format
};
1960 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1961 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1962 & $add_option_string ( "${value_str}=${combine_str}" );
1963 $done ->{ $combine } = 1 ;
1968 if ( $phash && $phash ->{ alias
}) {
1969 $phash = $format ->{ $phash ->{ alias
}};
1972 die "invalid key ' $key ' \n " if ! $phash ;
1973 die "internal error" if defined ( $phash ->{ alias
});
1975 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1977 & $add_option_string ( $value_str );
1979 & $add_option_string ( " $key =${value_str}" );
1983 # add default key first
1984 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1986 # add required keys first
1987 foreach my $key ( sort keys %$data ) {
1988 my $phash = $format ->{ $key };
1989 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1993 foreach my $key ( sort keys %$data ) {
1994 & $cond_add_key ( $key );
2000 sub schema_get_type_text
{
2001 my ( $phash, $style ) = @_ ;
2003 my $type = $phash ->{ type
} || 'string' ;
2005 if ( $phash ->{ typetext
}) {
2006 return $phash ->{ typetext
};
2007 } elsif ( $phash ->{ format_description
}) {
2008 return "< $phash ->{format_description}>" ;
2009 } elsif ( $phash ->{ enum
}) {
2010 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
2011 } elsif ( $phash ->{ pattern
}) {
2012 return $phash ->{ pattern
};
2013 } elsif ( $type eq 'integer' || $type eq 'number' ) {
2014 # NOTE: always access values as number (avoid converion to string)
2015 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
2016 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
2017 ( $phash ->{ maximum
} + 0 ) . ")" ;
2018 } elsif ( defined ( $phash ->{ minimum
})) {
2019 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
2020 } elsif ( defined ( $phash ->{ maximum
})) {
2021 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
2023 } elsif ( $type eq 'string' ) {
2024 if ( my $format = $phash ->{ format
}) {
2025 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
2026 if ( ref ( $format ) eq 'HASH' ) {
2028 $list_enums = 1 if $style && $style eq 'config-sub' ;
2029 return generate_typetext
( $format, $list_enums );