]>
git.proxmox.com Git - pve-common.git/blob - src/PVE/JSONSchema.pm
1 package PVE
:: JSONSchema
;
5 use Storable
; # for dclone
9 use Devel
:: Cycle
- quiet
; # todo: remove?
10 use PVE
:: Tools
qw(split_list $IPV6RE $IPV4RE ) ;
11 use PVE
:: Exception
qw(raise) ;
12 use HTTP
:: Status
qw(:constants) ;
13 use Net
:: IP
qw(:PROC) ;
19 register_standard_option
23 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
24 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
25 # see: http://json-schema.org/
27 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
29 my $standard_options = {};
30 sub register_standard_option
{
31 my ( $name, $schema ) = @_ ;
33 die "standard option ' $name ' already registered \n "
34 if $standard_options ->{ $name };
36 $standard_options ->{ $name } = $schema ;
39 sub get_standard_option
{
40 my ( $name, $base ) = @_ ;
42 my $std = $standard_options ->{ $name };
43 die "no such standard option ' $name ' \n " if ! $std ;
45 my $res = $base || {};
47 foreach my $opt ( keys %$std ) {
48 next if defined ( $res ->{ $opt });
49 $res ->{ $opt } = $std ->{ $opt };
55 register_standard_option
( 'pve-vmid' , {
56 description
=> "The (unique) ID of the VM." ,
57 type
=> 'integer' , format
=> 'pve-vmid' ,
61 register_standard_option
( 'pve-node' , {
62 description
=> "The cluster node name." ,
63 type
=> 'string' , format
=> 'pve-node' ,
66 register_standard_option
( 'pve-node-list' , {
67 description
=> "List of cluster node names." ,
68 type
=> 'string' , format
=> 'pve-node-list' ,
71 register_standard_option
( 'pve-iface' , {
72 description
=> "Network interface name." ,
73 type
=> 'string' , format
=> 'pve-iface' ,
74 minLength
=> 2 , maxLength
=> 20 ,
77 register_standard_option
( 'pve-storage-id' , {
78 description
=> "The storage identifier." ,
79 type
=> 'string' , format
=> 'pve-storage-id' ,
82 register_standard_option
( 'pve-config-digest' , {
83 description
=> 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.' ,
86 maxLength
=> 40 , # sha1 hex digest length is 40
89 register_standard_option
( 'skiplock' , {
90 description
=> "Ignore locks - only root is allowed to use this option." ,
95 register_standard_option
( 'extra-args' , {
96 description
=> "Extra arguments as array" ,
98 items
=> { type
=> 'string' },
102 register_standard_option
( 'fingerprint-sha256' , {
103 description
=> "Certificate SHA 256 fingerprint." ,
105 pattern
=> '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}' ,
108 register_standard_option
( 'pve-output-format' , {
110 description
=> 'Output format.' ,
111 enum
=> [ 'text' , 'json' , 'json-pretty' , 'yaml' ],
116 register_standard_option
( 'pve-snapshot-name' , {
117 description
=> "The name of the snapshot." ,
118 type
=> 'string' , format
=> 'pve-configid' ,
122 my $format_list = {};
124 sub register_format
{
125 my ( $format, $code ) = @_ ;
127 die "JSON schema format ' $format ' already registered \n "
128 if $format_list ->{ $format };
130 $format_list ->{ $format } = $code ;
135 return $format_list ->{ $format };
138 my $renderer_hash = {};
140 sub register_renderer
{
141 my ( $name, $code ) = @_ ;
143 die "renderer ' $name ' already registered \n "
144 if $renderer_hash ->{ $name };
146 $renderer_hash ->{ $name } = $code ;
151 return $renderer_hash ->{ $name };
154 # register some common type for pve
156 register_format
( 'string' , sub {}); # allow format => 'string-list'
158 register_format
( 'urlencoded' , \
& pve_verify_urlencoded
);
159 sub pve_verify_urlencoded
{
160 my ( $text, $noerr ) = @_ ;
161 if ( $text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/ ) {
162 return undef if $noerr ;
163 die "invalid urlencoded string: $text\n " ;
168 register_format
( 'pve-configid' , \
& pve_verify_configid
);
169 sub pve_verify_configid
{
170 my ( $id, $noerr ) = @_ ;
172 if ( $id !~ m/^[a-z][a-z0-9_]+$/i ) {
173 return undef if $noerr ;
174 die "invalid configuration ID ' $id ' \n " ;
179 PVE
:: JSONSchema
:: register_format
( 'pve-storage-id' , \
& parse_storage_id
);
180 sub parse_storage_id
{
181 my ( $storeid, $noerr ) = @_ ;
183 if ( $storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
184 return undef if $noerr ;
185 die "storage ID ' $storeid ' contains illegal characters \n " ;
191 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
192 sub pve_verify_vmid
{
193 my ( $vmid, $noerr ) = @_ ;
195 if ( $vmid !~ m/^[1-9][0-9]{2,8}$/ ) {
196 return undef if $noerr ;
197 die "value does not look like a valid VM ID \n " ;
202 register_format
( 'pve-node' , \
& pve_verify_node_name
);
203 sub pve_verify_node_name
{
204 my ( $node, $noerr ) = @_ ;
206 if ( $node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/ ) {
207 return undef if $noerr ;
208 die "value does not look like a valid node name \n " ;
213 register_format
( 'mac-addr' , \
& pve_verify_mac_addr
);
214 sub pve_verify_mac_addr
{
215 my ( $mac_addr, $noerr ) = @_ ;
217 # don't allow I/G bit to be set, most of the time it breaks things, see:
218 # https://pve.proxmox.com/pipermail/pve-devel/2019-March/035998.html
219 if ( $mac_addr !~ m/^[a-f0-9][02468ace](?::[a-f0-9]{2}){5}$/i ) {
220 return undef if $noerr ;
221 die "value does not look like a valid unicast MAC address \n " ;
226 register_standard_option
( 'mac-addr' , {
228 description
=> 'Unicast MAC address.' ,
229 verbose_description
=> 'A common MAC address with the I/G (Individual/Group) bit not set.' ,
230 format_description
=> "XX:XX:XX:XX:XX:XX" ,
232 format
=> 'mac-addr' ,
235 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
236 sub pve_verify_ipv4
{
237 my ( $ipv4, $noerr ) = @_ ;
239 if ( $ipv4 !~ m/^(?:$IPV4RE)$/ ) {
240 return undef if $noerr ;
241 die "value does not look like a valid IPv4 address \n " ;
246 register_format
( 'ipv6' , \
& pve_verify_ipv6
);
247 sub pve_verify_ipv6
{
248 my ( $ipv6, $noerr ) = @_ ;
250 if ( $ipv6 !~ m/^(?:$IPV6RE)$/ ) {
251 return undef if $noerr ;
252 die "value does not look like a valid IPv6 address \n " ;
257 register_format
( 'ip' , \
& pve_verify_ip
);
259 my ( $ip, $noerr ) = @_ ;
261 if ( $ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/ ) {
262 return undef if $noerr ;
263 die "value does not look like a valid IP address \n " ;
268 my $ipv4_mask_hash = {
285 '255.255.128.0' => 17 ,
286 '255.255.192.0' => 18 ,
287 '255.255.224.0' => 19 ,
288 '255.255.240.0' => 20 ,
289 '255.255.248.0' => 21 ,
290 '255.255.252.0' => 22 ,
291 '255.255.254.0' => 23 ,
292 '255.255.255.0' => 24 ,
293 '255.255.255.128' => 25 ,
294 '255.255.255.192' => 26 ,
295 '255.255.255.224' => 27 ,
296 '255.255.255.240' => 28 ,
297 '255.255.255.248' => 29 ,
298 '255.255.255.252' => 30 ,
299 '255.255.255.254' => 31 ,
300 '255.255.255.255' => 32 ,
303 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
304 sub pve_verify_ipv4mask
{
305 my ( $mask, $noerr ) = @_ ;
307 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
308 return undef if $noerr ;
309 die "value does not look like a valid IP netmask \n " ;
314 register_format
( 'CIDRv6' , \
& pve_verify_cidrv6
);
315 sub pve_verify_cidrv6
{
316 my ( $cidr, $noerr ) = @_ ;
318 if ( $cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 128 )) {
322 return undef if $noerr ;
323 die "value does not look like a valid IPv6 CIDR network \n " ;
326 register_format
( 'CIDRv4' , \
& pve_verify_cidrv4
);
327 sub pve_verify_cidrv4
{
328 my ( $cidr, $noerr ) = @_ ;
330 if ( $cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ( $1 > 7 ) && ( $1 <= 32 )) {
334 return undef if $noerr ;
335 die "value does not look like a valid IPv4 CIDR network \n " ;
338 register_format
( 'CIDR' , \
& pve_verify_cidr
);
339 sub pve_verify_cidr
{
340 my ( $cidr, $noerr ) = @_ ;
342 if (!( pve_verify_cidrv4
( $cidr, 1 ) ||
343 pve_verify_cidrv6
( $cidr, 1 )))
345 return undef if $noerr ;
346 die "value does not look like a valid CIDR network \n " ;
352 register_format
( 'pve-ipv4-config' , \
& pve_verify_ipv4_config
);
353 sub pve_verify_ipv4_config
{
354 my ( $config, $noerr ) = @_ ;
356 return $config if $config =~ /^(?:dhcp|manual)$/ ||
357 pve_verify_cidrv4
( $config, 1 );
358 return undef if $noerr ;
359 die "value does not look like a valid ipv4 network configuration \n " ;
362 register_format
( 'pve-ipv6-config' , \
& pve_verify_ipv6_config
);
363 sub pve_verify_ipv6_config
{
364 my ( $config, $noerr ) = @_ ;
366 return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
367 pve_verify_cidrv6
( $config, 1 );
368 return undef if $noerr ;
369 die "value does not look like a valid ipv6 network configuration \n " ;
372 register_format
( 'email' , \
& pve_verify_email
);
373 sub pve_verify_email
{
374 my ( $email, $noerr ) = @_ ;
376 if ( $email !~ /^[\w\+\-\~]+(\.[\w\+\-\~]+)*@[a-zA-Z0-9\-]+(\.[a-zA-Z0-9\-]+)*$/ ) {
377 return undef if $noerr ;
378 die "value does not look like a valid email address \n " ;
383 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
384 sub pve_verify_dns_name
{
385 my ( $name, $noerr ) = @_ ;
387 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
389 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
390 return undef if $noerr ;
391 die "value does not look like a valid DNS name \n " ;
396 # network interface name
397 register_format
( 'pve-iface' , \
& pve_verify_iface
);
398 sub pve_verify_iface
{
399 my ( $id, $noerr ) = @_ ;
401 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
402 return undef if $noerr ;
403 die "invalid network interface name ' $id ' \n " ;
408 # general addresses by name or IP
409 register_format
( 'address' , \
& pve_verify_address
);
410 sub pve_verify_address
{
411 my ( $addr, $noerr ) = @_ ;
413 if (!( pve_verify_ip
( $addr, 1 ) ||
414 pve_verify_dns_name
( $addr, 1 )))
416 return undef if $noerr ;
417 die "value does not look like a valid address: $addr\n " ;
422 register_format
( 'disk-size' , \
& pve_verify_disk_size
);
423 sub pve_verify_disk_size
{
424 my ( $size, $noerr ) = @_ ;
425 if (! defined ( parse_size
( $size ))) {
426 return undef if $noerr ;
427 die "value does not look like a valid disk size: $size\n " ;
432 register_standard_option
( 'spice-proxy' , {
433 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)." ,
434 type
=> 'string' , format
=> 'address' ,
437 register_standard_option
( 'remote-viewer-config' , {
438 description
=> "Returned values can be directly passed to the 'remote-viewer' application." ,
439 additionalProperties
=> 1 ,
441 type
=> { type
=> 'string' },
442 password
=> { type
=> 'string' },
443 proxy
=> { type
=> 'string' },
444 host
=> { type
=> 'string' },
445 'tls-port' => { type
=> 'integer' },
449 register_format
( 'pve-startup-order' , \
& pve_verify_startup_order
);
450 sub pve_verify_startup_order
{
451 my ( $value, $noerr ) = @_ ;
453 return $value if pve_parse_startup_order
( $value );
455 return undef if $noerr ;
457 die "unable to parse startup options \n " ;
462 type
=> 'number' , minimum
=> '0' ,
463 format_description
=> 'LIMIT' ,
466 my $bwlimit_format = {
469 description
=> 'default bandwidth limit in KiB/s' ,
473 description
=> 'bandwidth limit in KiB/s for restoring guests from backups' ,
477 description
=> 'bandwidth limit in KiB/s for migrating guests (including moving local disks)' ,
481 description
=> 'bandwidth limit in KiB/s for cloning disks' ,
485 description
=> 'bandwidth limit in KiB/s for moving disks' ,
488 register_format
( 'bwlimit' , $bwlimit_format );
489 register_standard_option
( 'bwlimit' , {
490 description
=> "Set bandwidth/io limits various operations." ,
493 format
=> $bwlimit_format,
496 sub pve_parse_startup_order
{
499 return undef if ! $value ;
503 foreach my $p ( split ( /,/ , $value )) {
504 next if $p =~ m/^\s*$/ ;
506 if ( $p =~ m/^(order=)?(\d+)$/ ) {
508 } elsif ( $p =~ m/^up=(\d+)$/ ) {
510 } elsif ( $p =~ m/^down=(\d+)$/ ) {
520 PVE
:: JSONSchema
:: register_standard_option
( 'pve-startup-order' , {
521 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." ,
523 type
=> 'string' , format
=> 'pve-startup-order' ,
524 typetext
=> '[[order=]\d+] [,up=\d+] [,down=\d+] ' ,
528 my ( $format, $value, $path ) = @_ ;
530 return parse_property_string
( $format, $value, $path ) if ref ( $format ) eq 'HASH' ;
531 return if $format eq 'regex' ;
533 if ( $format =~ m/^(.*)-a?list$/ ) {
535 my $code = $format_list ->{ $1 };
537 die "undefined format ' $format ' \n " if ! $code ;
539 # Note: we allow empty lists
540 foreach my $v ( split_list
( $value )) {
544 } elsif ( $format =~ m/^(.*)-opt$/ ) {
546 my $code = $format_list ->{ $1 };
548 die "undefined format ' $format ' \n " if ! $code ;
550 return if ! $value ; # allow empty string
556 my $code = $format_list ->{ $format };
558 die "undefined format ' $format ' \n " if ! $code ;
560 return parse_property_string
( $code, $value, $path ) if ref ( $code ) eq 'HASH' ;
568 return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/ ;
569 my ( $size, $unit ) = ( $1, $3 );
572 $size = $size * 1024 ;
573 } elsif ( $unit eq 'M' ) {
574 $size = $size * 1024 * 1024 ;
575 } elsif ( $unit eq 'G' ) {
576 $size = $size * 1024 * 1024 * 1024 ;
577 } elsif ( $unit eq 'T' ) {
578 $size = $size * 1024 * 1024 * 1024 * 1024 ;
589 my $kb = int ( $size/1024 );
590 return $size if $kb*1024 != $size ;
592 my $mb = int ( $kb/1024 );
593 return "${kb}K" if $mb*1024 != $kb ;
595 my $gb = int ( $mb/1024 );
596 return "${mb}M" if $gb*1024 != $mb ;
598 my $tb = int ( $gb/1024 );
599 return "${gb}G" if $tb*1024 != $gb ;
606 return 1 if $bool =~ m/^(1|on|yes|true)$/i ;
607 return 0 if $bool =~ m/^(0|off|no|false)$/i ;
611 sub parse_property_string
{
612 my ( $format, $data, $path, $additional_properties ) = @_ ;
614 # In property strings we default to not allowing additional properties
615 $additional_properties = 0 if ! defined ( $additional_properties );
617 # Support named formats here, too:
619 if ( my $desc = $format_list ->{ $format }) {
622 die "unknown format: $format\n " ;
624 } elsif ( ref ( $format ) ne 'HASH' ) {
625 die "unexpected format value of type " . ref ( $format ). " \n " ;
631 foreach my $part ( split ( /,/ , $data )) {
632 next if $part =~ /^\s*$/ ;
634 if ( $part =~ /^([^=]+)=(.+)$/ ) {
635 my ( $k, $v ) = ( $1, $2 );
636 die "duplicate key in comma-separated list property: $k\n " if defined ( $res ->{ $k });
637 my $schema = $format ->{ $k };
638 if ( my $alias = $schema ->{ alias
}) {
639 if ( my $key_alias = $schema ->{ keyAlias
}) {
640 die "key alias ' $key_alias ' is already defined \n " if defined ( $res ->{ $key_alias });
641 $res ->{ $key_alias } = $k ;
644 $schema = $format ->{ $k };
647 die "invalid key in comma-separated list property: $k\n " if ! $schema ;
648 if ( $schema ->{ type
} && $schema ->{ type
} eq 'boolean' ) {
649 $v = parse_boolean
( $v ) // $v ;
652 } elsif ( $part !~ /=/ ) {
653 die "duplicate key in comma-separated list property: $default_key\n " if $default_key ;
654 foreach my $key ( keys %$format ) {
655 if ( $format ->{ $key }->{ default_key
}) {
657 if (! $res ->{ $default_key }) {
658 $res ->{ $default_key } = $part ;
661 die "duplicate key in comma-separated list property: $default_key\n " ;
664 die "value without key, but schema does not define a default key \n " if ! $default_key ;
666 die "missing key in comma-separated list property \n " ;
671 check_object
( $path, $format, $res, $additional_properties, $errors );
672 if ( scalar ( %$errors )) {
673 raise
"format error \n " , errors
=> $errors ;
680 my ( $errors, $path, $msg ) = @_ ;
682 $path = '_root' if ! $path ;
684 if ( $errors ->{ $path }) {
685 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
687 $errors ->{ $path } = $msg ;
694 # see 'man perlretut'
695 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
701 return $value =~ m/^[+-]?\d+$/ ;
705 my ( $path, $type, $value, $errors ) = @_ ;
709 if (! defined ( $value )) {
710 return 1 if $type eq 'null' ;
714 if ( my $tt = ref ( $type )) {
715 if ( $tt eq 'ARRAY' ) {
716 foreach my $t ( @$type ) {
718 check_type
( $path, $t, $value, $tmperr );
719 return 1 if ! scalar ( %$tmperr );
721 my $ttext = join ( '|' , @$type );
722 add_error
( $errors, $path, "type check (' $ttext ') failed" );
724 } elsif ( $tt eq 'HASH' ) {
726 check_prop
( $value, $type, $path, $tmperr );
727 return 1 if ! scalar ( %$tmperr );
728 add_error
( $errors, $path, "type check failed" );
731 die "internal error - got reference type ' $tt '" ;
736 return 1 if $type eq 'any' ;
738 if ( $type eq 'null' ) {
739 if ( defined ( $value )) {
740 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
746 my $vt = ref ( $value );
748 if ( $type eq 'array' ) {
749 if (! $vt || $vt ne 'ARRAY' ) {
750 add_error
( $errors, $path, "type check (' $type ') failed" );
754 } elsif ( $type eq 'object' ) {
755 if (! $vt || $vt ne 'HASH' ) {
756 add_error
( $errors, $path, "type check (' $type ') failed" );
760 } elsif ( $type eq 'coderef' ) {
761 if (! $vt || $vt ne 'CODE' ) {
762 add_error
( $errors, $path, "type check (' $type ') failed" );
766 } elsif ( $type eq 'string' && $vt eq 'Regexp' ) {
767 # qr// regexes can be used as strings and make sense for format=regex
771 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
774 if ( $type eq 'string' ) {
775 return 1 ; # nothing to check ?
776 } elsif ( $type eq 'boolean' ) {
777 #if ($value =~ m/^(1|true|yes|on)$/i) {
780 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
781 } elsif ( $value eq '0' ) {
782 return 1 ; # return success (not value)
784 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
787 } elsif ( $type eq 'integer' ) {
788 if (! is_integer
( $value )) {
789 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
793 } elsif ( $type eq 'number' ) {
794 if (! is_number
( $value )) {
795 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
800 return 1 ; # no need to verify unknown types
810 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
812 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
814 my $st = ref ( $schema );
815 if (! $st || $st ne 'HASH' ) {
816 add_error
( $errors, $path, "Invalid schema definition." );
820 my $vt = ref ( $value );
821 if (! $vt || $vt ne 'HASH' ) {
822 add_error
( $errors, $path, "an object is required" );
826 foreach my $k ( keys %$schema ) {
827 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
830 foreach my $k ( keys %$value ) {
832 my $newpath = $path ?
" $path . $k " : $k ;
834 if ( my $subschema = $schema ->{ $k }) {
835 if ( my $requires = $subschema ->{ requires
}) {
836 if ( ref ( $requires )) {
837 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
838 check_prop
( $value, $requires, $path, $errors );
839 } elsif (! defined ( $value ->{ $requires })) {
840 add_error
( $errors, $path ?
" $path . $requires " : $requires,
841 "missing property - ' $newpath ' requires this property" );
845 next ; # value is already checked above
848 if ( defined ( $additional_properties ) && ! $additional_properties ) {
849 add_error
( $errors, $newpath, "property is not defined in schema " .
850 "and the schema does not allow additional properties" );
853 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
854 if ref ( $additional_properties );
858 sub check_object_warn
{
859 my ( $path, $schema, $value, $additional_properties ) = @_ ;
861 check_object
( $path, $schema, $value, $additional_properties, $errors );
862 if ( scalar ( %$errors )) {
863 foreach my $k ( keys %$errors ) {
864 warn "parse error: $k : $errors ->{ $k } \n " ;
872 my ( $value, $schema, $path, $errors ) = @_ ;
874 die "internal error - no schema" if ! $schema ;
875 die "internal error" if ! $errors ;
877 #print "check_prop $path\n" if $value;
879 my $st = ref ( $schema );
880 if (! $st || $st ne 'HASH' ) {
881 add_error
( $errors, $path, "Invalid schema definition." );
885 # if it extends another schema, it must pass that schema as well
886 if ( $schema ->{ extends
}) {
887 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
890 if (! defined ( $value )) {
891 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
892 if (! $schema ->{ optional
} && ! $schema ->{ alias
} && ! $schema ->{ group
}) {
893 add_error
( $errors, $path, "property is missing and it is not optional" );
898 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
900 if ( $schema ->{ disallow
}) {
902 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
903 add_error
( $errors, $path, "disallowed value was matched" );
908 if ( my $vt = ref ( $value )) {
910 if ( $vt eq 'ARRAY' ) {
911 if ( $schema ->{ items
}) {
912 my $it = ref ( $schema ->{ items
});
913 if ( $it && $it eq 'ARRAY' ) {
914 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
915 die "not implemented" ;
918 foreach my $el ( @$value ) {
919 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
925 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
926 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
927 $value, $schema ->{ additionalProperties
}, $errors );
933 if ( my $format = $schema ->{ format
}) {
934 eval { check_format
( $format, $value, $path ); };
936 add_error
( $errors, $path, "invalid format - $@ " );
941 if ( my $pattern = $schema ->{ pattern
}) {
942 if ( $value !~ m/^$pattern$/ ) {
943 add_error
( $errors, $path, "value does not match the regex pattern" );
948 if ( defined ( my $max = $schema ->{ maxLength
})) {
949 if ( length ( $value ) > $max ) {
950 add_error
( $errors, $path, "value may only be $max characters long" );
955 if ( defined ( my $min = $schema ->{ minLength
})) {
956 if ( length ( $value ) < $min ) {
957 add_error
( $errors, $path, "value must be at least $min characters long" );
962 if ( is_number
( $value )) {
963 if ( defined ( my $max = $schema ->{ maximum
})) {
965 add_error
( $errors, $path, "value must have a maximum value of $max " );
970 if ( defined ( my $min = $schema ->{ minimum
})) {
972 add_error
( $errors, $path, "value must have a minimum value of $min " );
978 if ( my $ea = $schema ->{ enum
}) {
981 foreach my $ev ( @$ea ) {
988 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
989 join ( ", " , @$ea ) . "'" );
996 my ( $instance, $schema, $errmsg ) = @_ ;
999 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
1001 # todo: cycle detection is only needed for debugging, I guess
1002 # we can disable that in the final release
1003 # todo: is there a better/faster way to detect cycles?
1005 find_cycle
( $instance, sub { $cycles = 1 });
1007 add_error
( $errors, undef , "data structure contains recursive cycles" );
1009 check_prop
( $instance, $schema, '' , $errors );
1012 if ( scalar ( %$errors )) {
1013 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
1019 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
1020 my $default_schema_noref = {
1021 description
=> "This is the JSON Schema for JSON Schemas." ,
1022 type
=> [ "object" ],
1023 additionalProperties
=> 0 ,
1026 type
=> [ "string" , "array" ],
1027 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
1032 enum
=> $schema_valid_types,
1034 enum
=> $schema_valid_types,
1038 description
=> "This indicates that the instance property in the instance object is not required." ,
1044 description
=> "This is a definition for the properties of an object value" ,
1050 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
1054 additionalProperties
=> {
1055 type
=> [ "boolean" , "object" ],
1056 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
1063 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
1068 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
1072 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
1079 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
1085 description
=> "A text representation of the type (used to generate documentation)." ,
1090 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." ,
1097 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
1102 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)." ,
1104 verbose_description
=> {
1107 description
=> "This provides a more verbose description." ,
1109 format_description
=> {
1112 description
=> "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings." ,
1117 description
=> "This provides the title of the property" ,
1122 description
=> "This is used to provide rendering hints to format cli command output." ,
1125 type
=> [ "string" , "object" ],
1127 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
1130 type
=> [ "string" , "object" ],
1132 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" ,
1137 description
=> "Whether this is the default key in a comma separated list property string." ,
1142 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." ,
1147 description
=> "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'." ,
1148 requires
=> 'alias' ,
1153 description
=> "This indicates the default for the instance property."
1157 description
=> "Bash completion function. This function should return a list of possible values." ,
1163 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." ,
1168 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
1171 # this is from hyper schema
1174 description
=> "This defines the link relations of the instance objects" ,
1181 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" ,
1185 description
=> "This is the name of the link relation" ,
1191 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
1200 description
=> "For CLI context, this defines the maximal width to print before truncating" ,
1206 my $default_schema = Storable
:: dclone
( $default_schema_noref );
1208 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
1209 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
1211 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
1212 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
1214 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
1215 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
1217 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
1218 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
1220 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
1221 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
1223 my $method_schema = {
1225 additionalProperties
=> 0 ,
1228 description
=> "This a description of the method" ,
1233 description
=> "This indicates the name of the function to call." ,
1236 additionalProperties
=> 1 ,
1251 description
=> "The HTTP method name." ,
1252 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
1257 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
1262 description
=> "Method downloads the file content (filename is the return value of the method)." ,
1267 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
1270 proxyto_callback
=> {
1272 description
=> "A function which is called to resolve the proxyto attribute. The default implementation returns the value of the 'proxyto' parameter." ,
1277 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
1279 additionalProperties
=> 0 ,
1282 description
=> "Describe access permissions." ,
1286 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
1288 enum
=> [ 'all' , 'world' ],
1292 description
=> "Array of permission checks (prefix notation)." ,
1299 description
=> "Used internally" ,
1303 description
=> "Used internally" ,
1308 description
=> "path for URL matching (uri template)" ,
1310 fragmentDelimiter
=> {
1312 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." ,
1317 description
=> "JSON Schema for parameters." ,
1322 description
=> "JSON Schema for return value." ,
1327 description
=> "method implementation (code reference)" ,
1332 description
=> "Delegate call to this class (perl class string)." ,
1335 additionalProperties
=> 0 ,
1341 fragmentDelimiter
=> { optional
=> 1 }
1349 sub validate_schema
{
1352 my $errmsg = "internal error - unable to verify schema \n " ;
1353 validate
( $schema, $default_schema, $errmsg );
1356 sub validate_method_info
{
1359 my $errmsg = "internal error - unable to verify method info \n " ;
1360 validate
( $info, $method_schema, $errmsg );
1362 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
1363 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
1366 # run a self test on load
1367 # make sure we can verify the default schema
1368 validate_schema
( $default_schema_noref );
1369 validate_schema
( $method_schema );
1371 # and now some utility methods (used by pve api)
1372 sub method_get_child_link
{
1375 return undef if ! $info ;
1377 my $schema = $info ->{ returns
};
1378 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
1380 my $links = $schema ->{ links
};
1381 return undef if ! $links ;
1384 foreach my $lnk ( @$links ) {
1385 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
1394 # a way to parse command line parameters, using a
1395 # schema to configure Getopt::Long
1397 my ( $schema, $args, $arg_param, $fixed_param, $param_mapping_hash ) = @_ ;
1399 if (! $schema || ! $schema ->{ properties
}) {
1400 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1401 if scalar ( @$args ) != 0 ;
1406 if ( $arg_param && ! ref ( $arg_param )) {
1407 my $pd = $schema ->{ properties
}->{ $arg_param };
1408 die "expected list format $pd ->{format}"
1409 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
1410 $list_param = $arg_param ;
1413 my @interactive = ();
1415 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
1416 my $pd = $schema ->{ properties
}->{ $prop };
1417 next if $list_param && $prop eq $list_param ;
1418 next if defined ( $fixed_param ->{ $prop });
1420 my $mapping = $param_mapping_hash ->{ $prop };
1421 if ( $mapping && $mapping ->{ interactive
}) {
1422 # interactive parameters such as passwords: make the argument
1423 # optional and call the mapping function afterwards.
1424 push @getopt, " $prop :s" ;
1425 push @interactive, [ $prop, $mapping ->{ func
}];
1426 } elsif ( $pd ->{ type
} eq 'boolean' ) {
1427 push @getopt, " $prop :s" ;
1429 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
1430 push @getopt, " $prop =s@" ;
1432 push @getopt, " $prop =s" ;
1437 Getopt
:: Long
:: Configure
( 'prefix_pattern=(--|-)' );
1440 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
1441 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
1445 $opts ->{ $list_param } = $args ;
1447 } elsif ( ref ( $arg_param )) {
1448 foreach my $arg_name ( @$arg_param ) {
1449 if ( $opts ->{ 'extra-args' }) {
1450 raise
( "internal error: extra-args must be the last argument \n " , code
=> HTTP_BAD_REQUEST
);
1452 if ( $arg_name eq 'extra-args' ) {
1453 $opts ->{ 'extra-args' } = $args ;
1457 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
) if ! @$args ;
1458 $opts ->{ $arg_name } = shift @$args ;
1460 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
) if @$args ;
1462 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
1463 if scalar ( @$args ) != 0 ;
1466 if ( ref ( $arg_param )) {
1467 foreach my $arg_name ( @$arg_param ) {
1468 if ( $arg_name eq 'extra-args' ) {
1469 $opts ->{ 'extra-args' } = [];
1471 raise
( "not enough arguments \n " , code
=> HTTP_BAD_REQUEST
);
1477 foreach my $entry ( @interactive ) {
1478 my ( $opt, $func ) = @$entry ;
1479 my $pd = $schema ->{ properties
}->{ $opt };
1480 my $value = $opts ->{ $opt };
1481 if ( defined ( $value ) || ! $pd ->{ optional
}) {
1482 $opts ->{ $opt } = $func ->( $value );
1486 # decode after Getopt as we are not sure how well it handles unicode
1487 foreach my $p ( keys %$opts ) {
1488 if (! ref ( $opts ->{ $p })) {
1489 $opts ->{ $p } = decode
( 'locale' , $opts ->{ $p });
1490 } elsif ( ref ( $opts ->{ $p }) eq 'ARRAY' ) {
1492 foreach my $v (@{ $opts ->{ $p }}) {
1493 push @$tmp, decode
( 'locale' , $v );
1496 } elsif ( ref ( $opts ->{ $p }) eq 'SCALAR' ) {
1497 $opts ->{ $p } = decode
( 'locale' , $$opts ->{ $p });
1499 raise
( "decoding options failed, unknown reference \n " , code
=> HTTP_BAD_REQUEST
);
1503 foreach my $p ( keys %$opts ) {
1504 if ( my $pd = $schema ->{ properties
}->{ $p }) {
1505 if ( $pd ->{ type
} eq 'boolean' ) {
1506 if ( $opts ->{ $p } eq '' ) {
1508 } elsif ( defined ( my $bool = parse_boolean
( $opts ->{ $p }))) {
1509 $opts ->{ $p } = $bool ;
1511 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1513 } elsif ( $pd ->{ format
}) {
1515 if ( $pd ->{ format
} =~ m/-list/ ) {
1516 # allow --vmid 100 --vmid 101 and --vmid 100,101
1517 # allow --dow mon --dow fri and --dow mon,fri
1518 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }}) if ref ( $opts ->{ $p }) eq 'ARRAY' ;
1519 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1520 # we encode array as \0 separated strings
1521 # Note: CGI.pm also use this encoding
1522 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1523 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1525 # st that split_list knows it is \0 terminated
1526 my $v = $opts ->{ $p }->[ 0 ];
1527 $opts ->{ $p } = " $v\0 " ;
1534 foreach my $p ( keys %$fixed_param ) {
1535 $opts ->{ $p } = $fixed_param ->{ $p };
1541 # A way to parse configuration data by giving a json schema
1543 my ( $schema, $filename, $raw ) = @_ ;
1545 # do fast check (avoid validate_schema($schema))
1546 die "got strange schema" if ! $schema ->{ type
} ||
1547 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1551 while ( $raw =~ /^\s*(.+?)\s*$/gm ) {
1554 next if $line =~ /^#/ ;
1556 if ( $line =~ m/^(\S+?):\s*(.*)$/ ) {
1559 if ( $schema ->{ properties
}->{ $key } &&
1560 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1562 $value = parse_boolean
( $value ) // $value ;
1564 $cfg ->{ $key } = $value ;
1566 warn "ignore config line: $line\n "
1571 check_prop
( $cfg, $schema, '' , $errors );
1573 foreach my $k ( keys %$errors ) {
1574 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1581 # generate simple key/value file
1583 my ( $schema, $filename, $cfg ) = @_ ;
1585 # do fast check (avoid validate_schema($schema))
1586 die "got strange schema" if ! $schema ->{ type
} ||
1587 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1589 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1593 foreach my $k ( keys %$cfg ) {
1594 $data .= " $k : $cfg ->{ $k } \n " ;
1600 # helpers used to generate our manual pages
1602 my $find_schema_default_key = sub {
1606 my $keyAliasProps = {};
1608 foreach my $key ( keys %$format ) {
1609 my $phash = $format ->{ $key };
1610 if ( $phash ->{ default_key
}) {
1611 die "multiple default keys in schema ( $default_key, $key ) \n "
1612 if defined ( $default_key );
1613 die "default key ' $key ' is an alias - this is not allowed \n "
1614 if defined ( $phash ->{ alias
});
1615 die "default key ' $key ' with keyAlias attribute is not allowed \n "
1616 if $phash ->{ keyAlias
};
1617 $default_key = $key ;
1619 my $key_alias = $phash ->{ keyAlias
};
1620 die "found keyAlias without 'alias definition for ' $key ' \n "
1621 if $key_alias && ! $phash ->{ alias
};
1623 if ( $phash ->{ alias
} && $key_alias ) {
1624 die "inconsistent keyAlias ' $key_alias ' definition"
1625 if defined ( $keyAliasProps ->{ $key_alias }) &&
1626 $keyAliasProps ->{ $key_alias } ne $phash ->{ alias
};
1627 $keyAliasProps ->{ $key_alias } = $phash ->{ alias
};
1631 return wantarray ?
( $default_key, $keyAliasProps ) : $default_key ;
1634 sub generate_typetext
{
1635 my ( $format, $list_enums ) = @_ ;
1637 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1642 my $add_option_string = sub {
1643 my ( $text, $optional ) = @_ ;
1649 $text = "[ $text ]" if $optional ;
1654 my $format_key_value = sub {
1655 my ( $key, $phash ) = @_ ;
1657 die "internal error" if defined ( $phash ->{ alias
});
1663 if ( my $desc = $phash ->{ format_description
}) {
1664 $typetext .= "< $desc >" ;
1665 } elsif ( my $text = $phash ->{ typetext
}) {
1667 } elsif ( my $enum = $phash ->{ enum
}) {
1668 if ( $list_enums || ( scalar ( @$enum ) <= 3 )) {
1669 $typetext .= '<' . join ( '|' , @$enum ) . '>' ;
1671 $typetext .= '<enum>' ;
1673 } elsif ( $phash ->{ type
} eq 'boolean' ) {
1674 $typetext .= '<1|0>' ;
1675 } elsif ( $phash ->{ type
} eq 'integer' ) {
1676 $typetext .= '<integer>' ;
1677 } elsif ( $phash ->{ type
} eq 'number' ) {
1678 $typetext .= '<number>' ;
1680 die "internal error: neither format_description nor typetext found for option ' $key '" ;
1683 if ( defined ( $default_key ) && ( $default_key eq $key )) {
1684 & $add_option_string ( "[ $keytext =] $typetext " , $phash ->{ optional
});
1686 & $add_option_string ( " $keytext = $typetext " , $phash ->{ optional
});
1692 my $cond_add_key = sub {
1695 return if $done ->{ $key }; # avoid duplicates
1699 my $phash = $format ->{ $key };
1701 return if ! $phash ; # should not happen
1703 return if $phash ->{ alias
};
1705 & $format_key_value ( $key, $phash );
1709 & $cond_add_key ( $default_key ) if defined ( $default_key );
1711 # add required keys first
1712 foreach my $key ( sort keys %$format ) {
1713 my $phash = $format ->{ $key };
1714 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1718 foreach my $key ( sort keys %$format ) {
1719 & $cond_add_key ( $key );
1722 foreach my $keyAlias ( sort keys %$keyAliasProps ) {
1723 & $add_option_string ( "< $keyAlias >=< $keyAliasProps ->{ $keyAlias }>" , 1 );
1729 sub print_property_string
{
1730 my ( $data, $format, $skip, $path ) = @_ ;
1732 if ( ref ( $format ) ne 'HASH' ) {
1733 my $schema = get_format
( $format );
1734 die "not a valid format: $format\n " if ! $schema ;
1739 check_object
( $path, $format, $data, undef , $errors );
1740 if ( scalar ( %$errors )) {
1741 raise
"format error" , errors
=> $errors ;
1744 my ( $default_key, $keyAliasProps ) = & $find_schema_default_key ( $format );
1749 my $add_option_string = sub {
1752 $res .= ',' if $add_sep ;
1757 my $format_value = sub {
1758 my ( $key, $value, $format ) = @_ ;
1760 if ( defined ( $format ) && ( $format eq 'disk-size' )) {
1761 return format_size
( $value );
1763 die "illegal value with commas for $key\n " if $value =~ /,/ ;
1768 my $done = { map { $_ => 1 } @$skip };
1770 my $cond_add_key = sub {
1771 my ( $key, $isdefault ) = @_ ;
1773 return if $done ->{ $key }; # avoid duplicates
1777 my $value = $data ->{ $key };
1779 return if ! defined ( $value );
1781 my $phash = $format ->{ $key };
1783 # try to combine values if we have key aliases
1784 if ( my $combine = $keyAliasProps ->{ $key }) {
1785 if ( defined ( my $combine_value = $data ->{ $combine })) {
1786 my $combine_format = $format ->{ $combine }->{ format
};
1787 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1788 my $combine_str = & $format_value ( $combine, $combine_value, $combine_format );
1789 & $add_option_string ( "${value_str}=${combine_str}" );
1790 $done ->{ $combine } = 1 ;
1795 if ( $phash && $phash ->{ alias
}) {
1796 $phash = $format ->{ $phash ->{ alias
}};
1799 die "invalid key ' $key ' \n " if ! $phash ;
1800 die "internal error" if defined ( $phash ->{ alias
});
1802 my $value_str = & $format_value ( $key, $value, $phash ->{ format
});
1804 & $add_option_string ( $value_str );
1806 & $add_option_string ( " $key =${value_str}" );
1810 # add default key first
1811 & $cond_add_key ( $default_key, 1 ) if defined ( $default_key );
1813 # add required keys first
1814 foreach my $key ( sort keys %$data ) {
1815 my $phash = $format ->{ $key };
1816 & $cond_add_key ( $key ) if $phash && ! $phash ->{ optional
};
1820 foreach my $key ( sort keys %$data ) {
1821 & $cond_add_key ( $key );
1827 sub schema_get_type_text
{
1828 my ( $phash, $style ) = @_ ;
1830 my $type = $phash ->{ type
} || 'string' ;
1832 if ( $phash ->{ typetext
}) {
1833 return $phash ->{ typetext
};
1834 } elsif ( $phash ->{ format_description
}) {
1835 return "< $phash ->{format_description}>" ;
1836 } elsif ( $phash ->{ enum
}) {
1837 return "<" . join ( ' | ' , sort @{ $phash ->{ enum
}}) . ">" ;
1838 } elsif ( $phash ->{ pattern
}) {
1839 return $phash ->{ pattern
};
1840 } elsif ( $type eq 'integer' || $type eq 'number' ) {
1841 # NOTE: always access values as number (avoid converion to string)
1842 if ( defined ( $phash ->{ minimum
}) && defined ( $phash ->{ maximum
})) {
1843 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - " .
1844 ( $phash ->{ maximum
} + 0 ) . ")" ;
1845 } elsif ( defined ( $phash ->{ minimum
})) {
1846 return "< $type > (" . ( $phash ->{ minimum
} + 0 ) . " - N)" ;
1847 } elsif ( defined ( $phash ->{ maximum
})) {
1848 return "< $type > (-N - " . ( $phash ->{ maximum
} + 0 ) . ")" ;
1850 } elsif ( $type eq 'string' ) {
1851 if ( my $format = $phash ->{ format
}) {
1852 $format = get_format
( $format ) if ref ( $format ) ne 'HASH' ;
1853 if ( ref ( $format ) eq 'HASH' ) {
1855 $list_enums = 1 if $style && $style eq 'config-sub' ;
1856 return generate_typetext
( $format, $list_enums );