schema_get_type_text: do not always expand enums
[pve-common.git] / src / PVE / JSONSchema.pm
1 package PVE::JSONSchema;
2
3 use strict;
4 use warnings;
5 use Storable; # for dclone
6 use Getopt::Long;
7 use Devel::Cycle -quiet; # todo: remove?
8 use PVE::Tools qw(split_list $IPV6RE $IPV4RE);
9 use PVE::Exception qw(raise);
10 use HTTP::Status qw(:constants);
11 use Net::IP qw(:PROC);
12 use Data::Dumper;
13
14 use base 'Exporter';
15
16 our @EXPORT_OK = qw(
17 register_standard_option 
18 get_standard_option
19 );
20
21 # Note: This class implements something similar to JSON schema, but it is not 100% complete. 
22 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
23 # see: http://json-schema.org/
24
25 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
26
27 my $standard_options = {};
28 sub register_standard_option {
29     my ($name, $schema) = @_;
30
31     die "standard option '$name' already registered\n" 
32         if $standard_options->{$name};
33
34     $standard_options->{$name} = $schema;
35 }
36
37 sub get_standard_option {
38     my ($name, $base) = @_;
39
40     my $std =  $standard_options->{$name};
41     die "no such standard option '$name'\n" if !$std;
42
43     my $res = $base || {};
44
45     foreach my $opt (keys %$std) {
46         next if defined($res->{$opt});
47         $res->{$opt} = $std->{$opt};
48     }
49
50     return $res;
51 };
52
53 register_standard_option('pve-vmid', {
54     description => "The (unique) ID of the VM.",
55     type => 'integer', format => 'pve-vmid',
56     minimum => 1
57 });
58
59 register_standard_option('pve-node', {
60     description => "The cluster node name.",
61     type => 'string', format => 'pve-node',
62 });
63
64 register_standard_option('pve-node-list', {
65     description => "List of cluster node names.",
66     type => 'string', format => 'pve-node-list',
67 });
68
69 register_standard_option('pve-iface', {
70     description => "Network interface name.",
71     type => 'string', format => 'pve-iface',
72     minLength => 2, maxLength => 20,
73 });
74
75 register_standard_option('pve-storage-id', {
76     description => "The storage identifier.",
77     type => 'string', format => 'pve-storage-id',
78 }); 
79
80 register_standard_option('pve-config-digest', {
81     description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
82     type => 'string',
83     optional => 1,
84     maxLength => 40, # sha1 hex digest lenght is 40
85 });
86
87 register_standard_option('extra-args', {
88     description => "Extra arguments as array",
89     type => 'array',
90     items => { type => 'string' },
91     optional => 1
92 });
93
94 my $format_list = {};
95
96 sub register_format {
97     my ($format, $code) = @_;
98
99     die "JSON schema format '$format' already registered\n" 
100         if $format_list->{$format};
101
102     $format_list->{$format} = $code;
103 }
104
105 sub get_format {
106     my ($format) = @_;
107     return $format_list->{$format};
108 }
109
110 # register some common type for pve
111
112 register_format('string', sub {}); # allow format => 'string-list'
113
114 register_format('urlencoded', \&pve_verify_urlencoded);
115 sub pve_verify_urlencoded {
116     my ($text, $noerr) = @_;
117     if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
118         return undef if $noerr;
119         die "invalid urlencoded string: $text\n";
120     }
121     return $text;
122 }
123
124 register_format('pve-configid', \&pve_verify_configid);
125 sub pve_verify_configid {
126     my ($id, $noerr) = @_;
127  
128     if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
129         return undef if $noerr;
130         die "invalid configuration ID '$id'\n"; 
131     }
132     return $id;
133 }
134
135 PVE::JSONSchema::register_format('pve-storage-id', \&parse_storage_id);
136 sub parse_storage_id {
137     my ($storeid, $noerr) = @_;
138
139     if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
140         return undef if $noerr;
141         die "storage ID '$storeid' contains illegal characters\n";
142     }
143     return $storeid;
144 }
145
146
147 register_format('pve-vmid', \&pve_verify_vmid);
148 sub pve_verify_vmid {
149     my ($vmid, $noerr) = @_;
150
151     if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
152         return undef if $noerr;
153         die "value does not look like a valid VM ID\n";
154     }
155     return $vmid;
156 }
157
158 register_format('pve-node', \&pve_verify_node_name);
159 sub pve_verify_node_name {
160     my ($node, $noerr) = @_;
161
162     if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
163         return undef if $noerr;
164         die "value does not look like a valid node name\n";
165     }
166     return $node;
167 }
168
169 register_format('ipv4', \&pve_verify_ipv4);
170 sub pve_verify_ipv4 {
171     my ($ipv4, $noerr) = @_;
172
173     if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
174         return undef if $noerr;
175         die "value does not look like a valid IPv4 address\n";
176     }
177     return $ipv4;
178 }
179
180 register_format('ipv6', \&pve_verify_ipv6);
181 sub pve_verify_ipv6 {
182     my ($ipv6, $noerr) = @_;
183
184     if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
185         return undef if $noerr;
186         die "value does not look like a valid IPv6 address\n";
187     }
188     return $ipv6;
189 }
190
191 register_format('ip', \&pve_verify_ip);
192 sub pve_verify_ip {
193     my ($ip, $noerr) = @_;
194
195     if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
196         return undef if $noerr;
197         die "value does not look like a valid IP address\n";
198     }
199     return $ip;
200 }
201
202 my $ipv4_mask_hash = {
203     '128.0.0.0' => 1,
204     '192.0.0.0' => 2,
205     '224.0.0.0' => 3,
206     '240.0.0.0' => 4,
207     '248.0.0.0' => 5,
208     '252.0.0.0' => 6,
209     '254.0.0.0' => 7,
210     '255.0.0.0' => 8,
211     '255.128.0.0' => 9,
212     '255.192.0.0' => 10,
213     '255.224.0.0' => 11,
214     '255.240.0.0' => 12,
215     '255.248.0.0' => 13,
216     '255.252.0.0' => 14,
217     '255.254.0.0' => 15,
218     '255.255.0.0' => 16,
219     '255.255.128.0' => 17,
220     '255.255.192.0' => 18,
221     '255.255.224.0' => 19,
222     '255.255.240.0' => 20,
223     '255.255.248.0' => 21,
224     '255.255.252.0' => 22,
225     '255.255.254.0' => 23,
226     '255.255.255.0' => 24,
227     '255.255.255.128' => 25,
228     '255.255.255.192' => 26,
229     '255.255.255.224' => 27,
230     '255.255.255.240' => 28,
231     '255.255.255.248' => 29,
232     '255.255.255.252' => 30,
233     '255.255.255.254' => 31,
234     '255.255.255.255' => 32,
235 };
236
237 register_format('ipv4mask', \&pve_verify_ipv4mask);
238 sub pve_verify_ipv4mask {
239     my ($mask, $noerr) = @_;
240
241     if (!defined($ipv4_mask_hash->{$mask})) {
242         return undef if $noerr;
243         die "value does not look like a valid IP netmask\n";
244     }
245     return $mask;
246 }
247
248 register_format('CIDRv6', \&pve_verify_cidrv6);
249 sub pve_verify_cidrv6 {
250     my ($cidr, $noerr) = @_;
251
252     if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) &&  ($1 <= 120)) {
253         return $cidr;
254     }
255
256     return undef if $noerr;
257     die "value does not look like a valid IPv6 CIDR network\n";
258 }
259
260 register_format('CIDRv4', \&pve_verify_cidrv4);
261 sub pve_verify_cidrv4 {
262     my ($cidr, $noerr) = @_;
263
264     if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) &&  ($1 <= 32)) {
265         return $cidr;
266     }
267
268     return undef if $noerr;
269     die "value does not look like a valid IPv4 CIDR network\n";
270 }
271
272 register_format('CIDR', \&pve_verify_cidr);
273 sub pve_verify_cidr {
274     my ($cidr, $noerr) = @_;
275
276     if (!(pve_verify_cidrv4($cidr, 1) ||
277           pve_verify_cidrv6($cidr, 1)))
278     {
279         return undef if $noerr;
280         die "value does not look like a valid CIDR network\n";
281     }
282
283     return $cidr;
284 }
285
286 register_format('pve-ipv4-config', \&pve_verify_ipv4_config);
287 sub pve_verify_ipv4_config {
288     my ($config, $noerr) = @_;
289
290     return $config if $config =~ /^(?:dhcp|manual)$/ ||
291                       pve_verify_cidrv4($config, 1);
292     return undef if $noerr;
293     die "value does not look like a valid ipv4 network configuration\n";
294 }
295
296 register_format('pve-ipv6-config', \&pve_verify_ipv6_config);
297 sub pve_verify_ipv6_config {
298     my ($config, $noerr) = @_;
299
300     return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
301                       pve_verify_cidrv6($config, 1);
302     return undef if $noerr;
303     die "value does not look like a valid ipv6 network configuration\n";
304 }
305
306 register_format('email', \&pve_verify_email);
307 sub pve_verify_email {
308     my ($email, $noerr) = @_;
309
310     # we use same regex as in Utils.js
311     if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,63}$/) {
312            return undef if $noerr;
313            die "value does not look like a valid email address\n";
314     }
315     return $email;
316 }
317
318 register_format('dns-name', \&pve_verify_dns_name);
319 sub pve_verify_dns_name {
320     my ($name, $noerr) = @_;
321
322     my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
323
324     if ($name !~ /^(${namere}\.)*${namere}$/) {
325            return undef if $noerr;
326            die "value does not look like a valid DNS name\n";
327     }
328     return $name;
329 }
330
331 # network interface name
332 register_format('pve-iface', \&pve_verify_iface);
333 sub pve_verify_iface {
334     my ($id, $noerr) = @_;
335  
336     if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
337         return undef if $noerr;
338         die "invalid network interface name '$id'\n"; 
339     }
340     return $id;
341 }
342
343 # general addresses by name or IP
344 register_format('address', \&pve_verify_address);
345 sub pve_verify_address {
346     my ($addr, $noerr) = @_;
347
348     if (!(pve_verify_ip($addr, 1) ||
349           pve_verify_dns_name($addr, 1)))
350     {
351            return undef if $noerr;
352            die "value does not look like a valid address: $addr\n";
353     }
354     return $addr;
355 }
356
357 register_format('disk-size', \&pve_verify_disk_size);
358 sub pve_verify_disk_size {
359     my ($size, $noerr) = @_;
360     if (!defined(parse_size($size))) {
361         return undef if $noerr;
362         die "value does not look like a valid disk size: $size\n";
363     }
364     return $size;
365 }
366
367 register_standard_option('spice-proxy', {
368     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 resonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).",
369     type => 'string', format => 'address',
370 }); 
371
372 register_standard_option('remote-viewer-config', {
373     description => "Returned values can be directly passed to the 'remote-viewer' application.",
374     additionalProperties => 1,
375     properties => {
376         type => { type => 'string' },
377         password => { type => 'string' },
378         proxy => { type => 'string' },
379         host => { type => 'string' },
380         'tls-port' => { type => 'integer' },
381     },
382 });
383
384 register_format('pve-startup-order', \&pve_verify_startup_order);
385 sub pve_verify_startup_order {
386     my ($value, $noerr) = @_;
387
388     return $value if pve_parse_startup_order($value);
389
390     return undef if $noerr;
391
392     die "unable to parse startup options\n";
393 }
394
395 sub pve_parse_startup_order {
396     my ($value) = @_;
397
398     return undef if !$value;
399
400     my $res = {};
401
402     foreach my $p (split(/,/, $value)) {
403         next if $p =~ m/^\s*$/;
404
405         if ($p =~ m/^(order=)?(\d+)$/) {
406             $res->{order} = $2;
407         } elsif ($p =~ m/^up=(\d+)$/) {
408             $res->{up} = $1;
409         } elsif ($p =~ m/^down=(\d+)$/) {
410             $res->{down} = $1;
411         } else {
412             return undef;
413         }
414     }
415
416     return $res;
417 }
418
419 PVE::JSONSchema::register_standard_option('pve-startup-order', {
420     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.",
421     optional => 1,
422     type => 'string', format => 'pve-startup-order',
423     typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
424 });
425
426 sub check_format {
427     my ($format, $value, $path) = @_;
428
429     return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
430     return if $format eq 'regex';
431
432     if ($format =~ m/^(.*)-a?list$/) {
433         
434         my $code = $format_list->{$1};
435
436         die "undefined format '$format'\n" if !$code;
437
438         # Note: we allow empty lists
439         foreach my $v (split_list($value)) {
440             &$code($v);
441         }
442
443     } elsif ($format =~ m/^(.*)-opt$/) {
444
445         my $code = $format_list->{$1};
446
447         die "undefined format '$format'\n" if !$code;
448
449         return if !$value; # allow empty string
450
451         &$code($value);
452
453    } else {
454
455         my $code = $format_list->{$format};
456
457         die "undefined format '$format'\n" if !$code;
458
459         return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
460         &$code($value);
461     }
462
463
464 sub parse_size {
465     my ($value) = @_;
466
467     return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
468     my ($size, $unit) = ($1, $3);
469     if ($unit) {
470         if ($unit eq 'K') {
471             $size = $size * 1024;
472         } elsif ($unit eq 'M') {
473             $size = $size * 1024 * 1024;
474         } elsif ($unit eq 'G') {
475             $size = $size * 1024 * 1024 * 1024;
476         } elsif ($unit eq 'T') {
477             $size = $size * 1024 * 1024 * 1024 * 1024;
478         }
479     }
480     return int($size);
481 };
482
483 sub format_size {
484     my ($size) = @_;
485
486     $size = int($size);
487
488     my $kb = int($size/1024);
489     return $size if $kb*1024 != $size;
490
491     my $mb = int($kb/1024);
492     return "${kb}K" if $mb*1024 != $kb;
493
494     my $gb = int($mb/1024);
495     return "${mb}M" if $gb*1024 != $mb;
496
497     my $tb = int($gb/1024);
498     return "${gb}G" if $tb*1024 != $gb;
499
500     return "${tb}T";
501 };
502
503 sub parse_property_string {
504     my ($format, $data, $path, $additional_properties) = @_;
505
506     # In property strings we default to not allowing additional properties
507     $additional_properties = 0 if !defined($additional_properties);
508
509     # Support named formats here, too:
510     if (!ref($format)) {
511         if (my $desc = $format_list->{$format}) {
512             $format = $desc;
513         } else {
514             die "unknown format: $format\n";
515         }
516     } elsif (ref($format) ne 'HASH') {
517         die "unexpected format value of type ".ref($format)."\n";
518     }
519
520     my $default_key;
521
522     my $res = {};
523     foreach my $part (split(/,/, $data)) {
524         next if $part =~ /^\s*$/;
525
526         if ($part =~ /^([^=]+)=(.+)$/) {
527             my ($k, $v) = ($1, $2);
528             die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
529             my $schema = $format->{$k};
530             if (my $alias = $schema->{alias}) {
531                 if (my $key_alias = $schema->{keyAlias}) {
532                     die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
533                     $res->{$key_alias} = $k;
534                 }
535                 $k = $alias;
536                 $schema = $format->{$k};
537             }
538
539             die "invalid key in comma-separated list property: $k\n" if !$schema;
540             if ($schema->{type} && $schema->{type} eq 'boolean') {
541                 $v = 1 if $v =~ m/^(1|on|yes|true)$/i;
542                 $v = 0 if $v =~ m/^(0|off|no|false)$/i;
543             }
544             $res->{$k} = $v;
545         } elsif ($part !~ /=/) {
546             die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
547             foreach my $key (keys %$format) {
548                 if ($format->{$key}->{default_key}) {
549                     $default_key = $key;
550                     if (!$res->{$default_key}) {
551                         $res->{$default_key} = $part;
552                         last;
553                     }
554                     die "duplicate key in comma-separated list property: $default_key\n";
555                 }
556             }
557             die "value without key, but schema does not define a default key\n" if !$default_key;
558         } else {
559             die "missing key in comma-separated list property\n";
560         }
561     }
562
563     my $errors = {};
564     check_object($path, $format, $res, $additional_properties, $errors);
565     if (scalar(%$errors)) {
566         raise "format error\n", errors => $errors;
567     }
568
569     return $res;
570 }
571
572 sub add_error {
573     my ($errors, $path, $msg) = @_;
574
575     $path = '_root' if !$path;
576     
577     if ($errors->{$path}) {
578         $errors->{$path} = join ('\n', $errors->{$path}, $msg);
579     } else {
580         $errors->{$path} = $msg;
581     }
582 }
583
584 sub is_number {
585     my $value = shift;
586
587     # see 'man perlretut'
588     return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/; 
589 }
590
591 sub is_integer {
592     my $value = shift;
593
594     return $value =~ m/^[+-]?\d+$/;
595 }
596
597 sub check_type {
598     my ($path, $type, $value, $errors) = @_;
599
600     return 1 if !$type;
601
602     if (!defined($value)) {
603         return 1 if $type eq 'null';
604         die "internal error" 
605     }
606
607     if (my $tt = ref($type)) {
608         if ($tt eq 'ARRAY') {
609             foreach my $t (@$type) {
610                 my $tmperr = {};
611                 check_type($path, $t, $value, $tmperr);
612                 return 1 if !scalar(%$tmperr); 
613             }
614             my $ttext = join ('|', @$type);
615             add_error($errors, $path, "type check ('$ttext') failed"); 
616             return undef;
617         } elsif ($tt eq 'HASH') {
618             my $tmperr = {};
619             check_prop($value, $type, $path, $tmperr);
620             return 1 if !scalar(%$tmperr); 
621             add_error($errors, $path, "type check failed");         
622             return undef;
623         } else {
624             die "internal error - got reference type '$tt'";
625         }
626
627     } else {
628
629         return 1 if $type eq 'any';
630
631         if ($type eq 'null') {
632             if (defined($value)) {
633                 add_error($errors, $path, "type check ('$type') failed - value is not null");
634                 return undef;
635             }
636             return 1;
637         }
638
639         my $vt = ref($value);
640
641         if ($type eq 'array') {
642             if (!$vt || $vt ne 'ARRAY') {
643                 add_error($errors, $path, "type check ('$type') failed");
644                 return undef;
645             }
646             return 1;
647         } elsif ($type eq 'object') {
648             if (!$vt || $vt ne 'HASH') {
649                 add_error($errors, $path, "type check ('$type') failed");
650                 return undef;
651             }
652             return 1;
653         } elsif ($type eq 'coderef') {
654             if (!$vt || $vt ne 'CODE') {
655                 add_error($errors, $path, "type check ('$type') failed");
656                 return undef;
657             }
658             return 1;
659         } elsif ($type eq 'string' && $vt eq 'Regexp') {
660             # qr// regexes can be used as strings and make sense for format=regex
661             return 1;
662         } else {
663             if ($vt) {
664                 add_error($errors, $path, "type check ('$type') failed - got $vt");
665                 return undef;
666             } else {
667                 if ($type eq 'string') {
668                     return 1; # nothing to check ?
669                 } elsif ($type eq 'boolean') {
670                     #if ($value =~ m/^(1|true|yes|on)$/i) {
671                     if ($value eq '1') {
672                         return 1;
673                     #} elsif ($value =~ m/^(0|false|no|off)$/i) {
674                     } elsif ($value eq '0') {
675                         return 0;
676                     } else {
677                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
678                         return undef;
679                     }
680                 } elsif ($type eq 'integer') {
681                     if (!is_integer($value)) {
682                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
683                         return undef;
684                     }
685                     return 1;
686                 } elsif ($type eq 'number') {
687                     if (!is_number($value)) {
688                         add_error($errors, $path, "type check ('$type') failed - got '$value'");
689                         return undef;
690                     }
691                     return 1;
692                 } else {
693                     return 1; # no need to verify unknown types
694                 }
695             }
696         }
697     }  
698
699     return undef;
700 }
701
702 sub check_object {
703     my ($path, $schema, $value, $additional_properties, $errors) = @_;
704
705     # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
706
707     my $st = ref($schema);
708     if (!$st || $st ne 'HASH') {
709         add_error($errors, $path, "Invalid schema definition.");
710         return;
711     }
712
713     my $vt = ref($value);
714     if (!$vt || $vt ne 'HASH') {
715         add_error($errors, $path, "an object is required");
716         return;
717     }
718
719     foreach my $k (keys %$schema) {
720         check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
721     }
722
723     foreach my $k (keys %$value) {
724
725         my $newpath =  $path ? "$path.$k" : $k;
726
727         if (my $subschema = $schema->{$k}) {
728             if (my $requires = $subschema->{requires}) {
729                 if (ref($requires)) {
730                     #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
731                     check_prop($value, $requires, $path, $errors);
732                 } elsif (!defined($value->{$requires})) {
733                     add_error($errors, $path ? "$path.$requires" : $requires, 
734                               "missing property - '$newpath' requires this property");
735                 }
736             }
737
738             next; # value is already checked above
739         }
740
741         if (defined ($additional_properties) && !$additional_properties) {
742             add_error($errors, $newpath, "property is not defined in schema " .
743                       "and the schema does not allow additional properties");
744             next;
745         }
746         check_prop($value->{$k}, $additional_properties, $newpath, $errors)
747             if ref($additional_properties);
748     }
749 }
750
751 sub check_object_warn {
752     my ($path, $schema, $value, $additional_properties) = @_;
753     my $errors = {};
754     check_object($path, $schema, $value, $additional_properties, $errors);
755     if (scalar(%$errors)) {
756         foreach my $k (keys %$errors) {
757             warn "parse error: $k: $errors->{$k}\n";
758         }
759         return 0;
760     }
761     return 1;
762 }
763
764 sub check_prop {
765     my ($value, $schema, $path, $errors) = @_;
766
767     die "internal error - no schema" if !$schema;
768     die "internal error" if !$errors;
769
770     #print "check_prop $path\n" if $value;
771
772     my $st = ref($schema);
773     if (!$st || $st ne 'HASH') {
774         add_error($errors, $path, "Invalid schema definition.");
775         return;
776     }
777
778     # if it extends another schema, it must pass that schema as well
779     if($schema->{extends}) {
780         check_prop($value, $schema->{extends}, $path, $errors);
781     }
782
783     if (!defined ($value)) {
784         return if $schema->{type} && $schema->{type} eq 'null';
785         if (!$schema->{optional} && !$schema->{alias} && !$schema->{group}) {
786             add_error($errors, $path, "property is missing and it is not optional");
787         }
788         return;
789     }
790
791     return if !check_type($path, $schema->{type}, $value, $errors);
792
793     if ($schema->{disallow}) {
794         my $tmperr = {};
795         if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
796             add_error($errors, $path, "disallowed value was matched");
797             return;
798         }
799     }
800
801     if (my $vt = ref($value)) {
802
803         if ($vt eq 'ARRAY') {
804             if ($schema->{items}) {
805                 my $it = ref($schema->{items});
806                 if ($it && $it eq 'ARRAY') {
807                     #die "implement me $path: $vt " . Dumper($schema) ."\n".  Dumper($value);
808                     die "not implemented";
809                 } else {
810                     my $ind = 0;
811                     foreach my $el (@$value) {
812                         check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
813                         $ind++;
814                     }
815                 }
816             }
817             return; 
818         } elsif ($schema->{properties} || $schema->{additionalProperties}) {
819             check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
820                          $value, $schema->{additionalProperties}, $errors);
821             return;
822         }
823
824     } else {
825
826         if (my $format = $schema->{format}) {
827             eval { check_format($format, $value, $path); };
828             if ($@) {
829                 add_error($errors, $path, "invalid format - $@");
830                 return;
831             }
832         }
833
834         if (my $pattern = $schema->{pattern}) {
835             if ($value !~ m/^$pattern$/) {
836                 add_error($errors, $path, "value does not match the regex pattern");
837                 return;
838             }
839         }
840
841         if (defined (my $max = $schema->{maxLength})) {
842             if (length($value) > $max) {
843                 add_error($errors, $path, "value may only be $max characters long");
844                 return;
845             }
846         }
847
848         if (defined (my $min = $schema->{minLength})) {
849             if (length($value) < $min) {
850                 add_error($errors, $path, "value must be at least $min characters long");
851                 return;
852             }
853         }
854         
855         if (is_number($value)) {
856             if (defined (my $max = $schema->{maximum})) {
857                 if ($value > $max) { 
858                     add_error($errors, $path, "value must have a maximum value of $max");
859                     return;
860                 }
861             }
862
863             if (defined (my $min = $schema->{minimum})) {
864                 if ($value < $min) { 
865                     add_error($errors, $path, "value must have a minimum value of $min");
866                     return;
867                 }
868             }
869         }
870
871         if (my $ea = $schema->{enum}) {
872
873             my $found;
874             foreach my $ev (@$ea) {
875                 if ($ev eq $value) {
876                     $found = 1;
877                     last;
878                 }
879             }
880             if (!$found) {
881                 add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
882                           join(", ", @$ea) . "'");
883             }
884         }
885     }
886 }
887
888 sub validate {
889     my ($instance, $schema, $errmsg) = @_;
890
891     my $errors = {};
892     $errmsg = "Parameter verification failed.\n" if !$errmsg;
893
894     # todo: cycle detection is only needed for debugging, I guess
895     # we can disable that in the final release
896     # todo: is there a better/faster way to detect cycles?
897     my $cycles = 0;
898     find_cycle($instance, sub { $cycles = 1 });
899     if ($cycles) {
900         add_error($errors, undef, "data structure contains recursive cycles");
901     } elsif ($schema) {
902         check_prop($instance, $schema, '', $errors);
903     }
904     
905     if (scalar(%$errors)) {
906         raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
907     }
908
909     return 1;
910 }
911
912 my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
913 my $default_schema_noref = {
914     description => "This is the JSON Schema for JSON Schemas.",
915     type => [ "object" ],
916     additionalProperties => 0,
917     properties => {
918         type => {
919             type => ["string", "array"],
920             description => "This is a type definition value. This can be a simple type, or a union type",
921             optional => 1,
922             default => "any",
923             items => {
924                 type => "string",
925                 enum => $schema_valid_types,
926             },
927             enum => $schema_valid_types,
928         },
929         optional => {
930             type => "boolean",
931             description => "This indicates that the instance property in the instance object is not required.",
932             optional => 1,
933             default => 0
934         },
935         properties => {
936             type => "object",
937             description => "This is a definition for the properties of an object value",
938             optional => 1,
939             default => {},
940         },
941         items => {
942             type => "object",
943             description => "When the value is an array, this indicates the schema to use to validate each item in an array",
944             optional => 1,
945             default => {},
946         },
947         additionalProperties => {
948             type => [ "boolean", "object"],
949             description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
950             optional => 1,
951             default => {},
952         },
953         minimum => {
954             type => "number",
955             optional => 1,
956             description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
957         },
958         maximum => {
959             type => "number",
960             optional => 1,
961             description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
962         },
963         minLength => {
964             type => "integer",
965             description => "When the instance value is a string, this indicates minimum length of the string",
966             optional => 1,
967             minimum => 0,
968             default => 0,
969         },      
970         maxLength => {
971             type => "integer",
972             description => "When the instance value is a string, this indicates maximum length of the string.",
973             optional => 1,
974         },
975         typetext => {
976             type => "string",
977             optional => 1,
978             description => "A text representation of the type (used to generate documentation).",
979         },
980         pattern => {
981             type => "string",
982             format => "regex",
983             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.",
984             optional => 1,
985             default => ".*",
986         },
987         enum => {
988             type => "array",
989             optional => 1,
990             description => "This provides an enumeration of possible values that are valid for the instance property.",
991         },
992         description => {
993             type => "string",
994             optional => 1,
995             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).",
996         },
997         verbose_description => {
998             type => "string",
999             optional => 1,
1000             description => "This provides a more verbose description.",
1001         },
1002         format_description => {
1003             type => "string",
1004             optional => 1,
1005             description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
1006         },
1007         title => {
1008             type => "string",
1009             optional => 1,
1010             description => "This provides the title of the property",
1011         },
1012         requires => {
1013             type => [ "string", "object" ],
1014             optional => 1,
1015             description => "indicates a required property or a schema that must be validated if this property is present",
1016         },
1017         format => {
1018             type => [ "string", "object" ],
1019             optional => 1,
1020             description => "This indicates what format the data is among some predefined formats which may include:\n\ndate - a string following the ISO format \naddress \nschema - a schema definition object \nperson \npage \nhtml - a string representing HTML",
1021         },
1022         default_key => {
1023             type => "boolean",
1024             optional => 1,
1025             description => "Whether this is the default key in a comma separated list property string.",
1026         },
1027         alias => {
1028             type => 'string',
1029             optional => 1,
1030             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.",
1031         },
1032         keyAlias => {
1033             type => 'string',
1034             optional => 1,
1035             description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
1036             requires => 'alias',
1037         },
1038         default => {
1039             type => "any",
1040             optional => 1,
1041             description => "This indicates the default for the instance property."
1042         },
1043         completion => {
1044             type => 'coderef',
1045             description => "Bash completion function. This function should return a list of possible values.",
1046             optional => 1,
1047         },
1048         disallow => {
1049             type => "object",
1050             optional => 1,
1051             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.",
1052         },
1053         extends => {
1054             type => "object",
1055             optional => 1,
1056             description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
1057             default => {},
1058         },
1059         # this is from hyper schema
1060         links => {
1061             type => "array",
1062             description => "This defines the link relations of the instance objects",
1063             optional => 1,
1064             items => {
1065                 type => "object",
1066                 properties => {
1067                     href => {
1068                         type => "string",
1069                         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",
1070                     },
1071                     rel => {
1072                         type => "string",
1073                         description => "This is the name of the link relation",
1074                         optional => 1,
1075                         default => "full",
1076                     },
1077                     method => {
1078                         type => "string",
1079                         description => "For submission links, this defines the method that should be used to access the target resource",
1080                         optional => 1,
1081                         default => "GET",
1082                     },
1083                 },
1084             },
1085         },
1086     }   
1087 };
1088
1089 my $default_schema = Storable::dclone($default_schema_noref);
1090
1091 $default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
1092 $default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
1093
1094 $default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
1095 $default_schema->{properties}->{items}->{additionalProperties} = 0;
1096
1097 $default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
1098 $default_schema->{properties}->{disallow}->{additionalProperties} = 0;
1099
1100 $default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
1101 $default_schema->{properties}->{requires}->{additionalProperties} = 0;
1102
1103 $default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
1104 $default_schema->{properties}->{extends}->{additionalProperties} = 0;
1105
1106 my $method_schema = {
1107     type => "object",
1108     additionalProperties => 0,
1109     properties => {
1110         description => {
1111             description => "This a description of the method",
1112             optional => 1,
1113         },
1114         name => {
1115             type =>  'string',
1116             description => "This indicates the name of the function to call.",
1117             optional => 1,
1118             requires => {
1119                 additionalProperties => 1,
1120                 properties => {
1121                     name => {},
1122                     description => {},
1123                     code => {},
1124                     method => {},
1125                     parameters => {},
1126                     path => {},
1127                     parameters => {},
1128                     returns => {},
1129                 }             
1130             },
1131         },
1132         method => {
1133             type =>  'string',
1134             description => "The HTTP method name.",
1135             enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
1136             optional => 1,
1137         },
1138         protected => {
1139             type => 'boolean',
1140             description => "Method needs special privileges - only pvedaemon can execute it",            
1141             optional => 1,
1142         },
1143         proxyto => {
1144             type =>  'string',
1145             description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
1146             optional => 1,
1147         },
1148         permissions => {
1149             type => 'object',
1150             description => "Required access permissions. By default only 'root' is allowed to access this method.",
1151             optional => 1,
1152             additionalProperties => 0,
1153             properties => {
1154                 description => {
1155                      description => "Describe access permissions.",
1156                      optional => 1,
1157                 },
1158                 user => {
1159                     description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.", 
1160                     type => 'string', 
1161                     enum => ['all', 'world'],
1162                     optional => 1,
1163                 },
1164                 check => {
1165                     description => "Array of permission checks (prefix notation).",
1166                     type => 'array', 
1167                     optional => 1 
1168                 },
1169             },
1170         },
1171         match_name => {
1172             description => "Used internally",
1173             optional => 1,
1174         },
1175         match_re => {
1176             description => "Used internally",
1177             optional => 1,
1178         },
1179         path => {
1180             type =>  'string',
1181             description => "path for URL matching (uri template)",
1182         },
1183         fragmentDelimiter => {
1184             type => 'string',
1185             description => "A ways to override the default fragment delimiter '/'. This onyl works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.",            
1186             optional => 1,
1187         },
1188         parameters => {
1189             type => 'object',
1190             description => "JSON Schema for parameters.",
1191             optional => 1,
1192         },
1193         formatter => {
1194             type => 'object',
1195             description => "Used to store page formatter information (set by PVE::RESTHandler->register_page_formatter).",
1196             optional => 1,
1197         },
1198         returns => {
1199             type => 'object',
1200             description => "JSON Schema for return value.",
1201             optional => 1,
1202         },
1203         code => {
1204             type => 'coderef',
1205             description => "method implementaion (code reference)",
1206             optional => 1,
1207         },
1208         subclass => {
1209             type => 'string',
1210             description => "Delegate call to this class (perl class string).",
1211             optional => 1,
1212             requires => {
1213                 additionalProperties => 0,
1214                 properties => {
1215                     subclass => {},
1216                     path => {},
1217                     match_name => {},
1218                     match_re => {},
1219                     fragmentDelimiter => { optional => 1 }
1220                 }             
1221             },
1222         }, 
1223     },
1224
1225 };
1226
1227 sub validate_schema {
1228     my ($schema) = @_; 
1229
1230     my $errmsg = "internal error - unable to verify schema\n";
1231     validate($schema, $default_schema, $errmsg);
1232 }
1233
1234 sub validate_method_info {
1235     my $info = shift;
1236
1237     my $errmsg = "internal error - unable to verify method info\n";
1238     validate($info, $method_schema, $errmsg);
1239  
1240     validate_schema($info->{parameters}) if $info->{parameters};
1241     validate_schema($info->{returns}) if $info->{returns};
1242 }
1243
1244 # run a self test on load
1245 # make sure we can verify the default schema 
1246 validate_schema($default_schema_noref);
1247 validate_schema($method_schema);
1248
1249 # and now some utility methods (used by pve api)
1250 sub method_get_child_link {
1251     my ($info) = @_;
1252
1253     return undef if !$info;
1254
1255     my $schema = $info->{returns};
1256     return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
1257
1258     my $links = $schema->{links};
1259     return undef if !$links;
1260
1261     my $found;
1262     foreach my $lnk (@$links) {
1263         if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
1264             $found = $lnk;
1265             last;
1266         }
1267     }
1268
1269     return $found;
1270 }
1271
1272 # a way to parse command line parameters, using a 
1273 # schema to configure Getopt::Long
1274 sub get_options {
1275     my ($schema, $args, $arg_param, $fixed_param, $pwcallback) = @_;
1276
1277     if (!$schema || !$schema->{properties}) {
1278         raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1279             if scalar(@$args) != 0;
1280         return {};
1281     }
1282
1283     my $list_param;
1284     if ($arg_param && !ref($arg_param)) {
1285         my $pd = $schema->{properties}->{$arg_param};
1286         die "expected list format $pd->{format}"
1287             if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
1288         $list_param = $arg_param;
1289     }
1290
1291     my @getopt = ();
1292     foreach my $prop (keys %{$schema->{properties}}) {
1293         my $pd = $schema->{properties}->{$prop};
1294         next if $list_param && $prop eq $list_param;
1295         next if defined($fixed_param->{$prop});
1296
1297         if ($prop eq 'password' && $pwcallback) {
1298             # we do not accept plain password on input line, instead
1299             # we turn this into a boolean option and ask for password below
1300             # using $pwcallback() (for security reasons).
1301             push @getopt, "$prop";
1302         } elsif ($pd->{type} eq 'boolean') {
1303             push @getopt, "$prop:s";
1304         } else {
1305             if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
1306                 push @getopt, "$prop=s@";
1307             } else {
1308                 push @getopt, "$prop=s";
1309             }
1310         }
1311     }
1312
1313     Getopt::Long::Configure('prefix_pattern=(--|-)');
1314
1315     my $opts = {};
1316     raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
1317         if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
1318
1319     if (@$args) {
1320         if ($list_param) {
1321             $opts->{$list_param} = $args;
1322             $args = [];
1323         } elsif (ref($arg_param)) {
1324             foreach my $arg_name (@$arg_param) {
1325                 if ($opts->{'extra-args'}) {
1326                     raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
1327                 }
1328                 if ($arg_name eq 'extra-args') {
1329                     $opts->{'extra-args'} = $args;
1330                     $args = [];
1331                     next;
1332                 }
1333                 raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
1334                 $opts->{$arg_name} = shift @$args;
1335             }
1336             raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
1337         } else {
1338             raise("too many arguments\n", code => HTTP_BAD_REQUEST)
1339                 if scalar(@$args) != 0;
1340         }
1341     }
1342
1343     if (my $pd = $schema->{properties}->{password}) {
1344         if ($pd->{type} ne 'boolean' && $pwcallback) {
1345             if ($opts->{password} || !$pd->{optional}) {
1346                 $opts->{password} = &$pwcallback(); 
1347             }
1348         }
1349     }
1350
1351     $opts = PVE::Tools::decode_utf8_parameters($opts);
1352
1353     foreach my $p (keys %$opts) {
1354         if (my $pd = $schema->{properties}->{$p}) {
1355             if ($pd->{type} eq 'boolean') {
1356                 if ($opts->{$p} eq '') {
1357                     $opts->{$p} = 1;
1358                 } elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
1359                     $opts->{$p} = 1;
1360                 } elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
1361                     $opts->{$p} = 0;
1362                 } else {
1363                     raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
1364                 }
1365             } elsif ($pd->{format}) {
1366
1367                 if ($pd->{format} =~ m/-list/) {
1368                     # allow --vmid 100 --vmid 101 and --vmid 100,101
1369                     # allow --dow mon --dow fri and --dow mon,fri
1370                     $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
1371                 } elsif ($pd->{format} =~ m/-alist/) {
1372                     # we encode array as \0 separated strings
1373                     # Note: CGI.pm also use this encoding
1374                     if (scalar(@{$opts->{$p}}) != 1) {
1375                         $opts->{$p} = join("\0", @{$opts->{$p}});
1376                     } else {
1377                         # st that split_list knows it is \0 terminated
1378                         my $v = $opts->{$p}->[0];
1379                         $opts->{$p} = "$v\0";
1380                     }
1381                 }
1382             }
1383         }       
1384     }
1385
1386     foreach my $p (keys %$fixed_param) {
1387         $opts->{$p} = $fixed_param->{$p};
1388     }
1389
1390     return $opts;
1391 }
1392
1393 # A way to parse configuration data by giving a json schema
1394 sub parse_config {
1395     my ($schema, $filename, $raw) = @_;
1396
1397     # do fast check (avoid validate_schema($schema))
1398     die "got strange schema" if !$schema->{type} || 
1399         !$schema->{properties} || $schema->{type} ne 'object';
1400
1401     my $cfg = {};
1402
1403     while ($raw =~ /^\s*(.+?)\s*$/gm) {
1404         my $line = $1;
1405
1406         next if $line =~ /^#/;
1407
1408         if ($line =~ m/^(\S+?):\s*(.*)$/) {
1409             my $key = $1;
1410             my $value = $2;
1411             if ($schema->{properties}->{$key} && 
1412                 $schema->{properties}->{$key}->{type} eq 'boolean') {
1413
1414                 $value = 1 if $value =~ m/^(1|on|yes|true)$/i; 
1415                 $value = 0 if $value =~ m/^(0|off|no|false)$/i; 
1416             }
1417             $cfg->{$key} = $value;
1418         } else {
1419             warn "ignore config line: $line\n"
1420         }
1421     }
1422
1423     my $errors = {};
1424     check_prop($cfg, $schema, '', $errors);
1425
1426     foreach my $k (keys %$errors) {
1427         warn "parse error in '$filename' - '$k': $errors->{$k}\n";
1428         delete $cfg->{$k};
1429     } 
1430
1431     return $cfg;
1432 }
1433
1434 # generate simple key/value file
1435 sub dump_config {
1436     my ($schema, $filename, $cfg) = @_;
1437
1438     # do fast check (avoid validate_schema($schema))
1439     die "got strange schema" if !$schema->{type} || 
1440         !$schema->{properties} || $schema->{type} ne 'object';
1441
1442     validate($cfg, $schema, "validation error in '$filename'\n");
1443
1444     my $data = '';
1445
1446     foreach my $k (keys %$cfg) {
1447         $data .= "$k: $cfg->{$k}\n";
1448     }
1449
1450     return $data;
1451 }
1452
1453 # helpers used to generate our manual pages
1454
1455 my $find_schema_default_key = sub {
1456     my ($format) = @_;
1457
1458     my $default_key;
1459     my $keyAliasProps = {};
1460
1461     foreach my $key (keys %$format) {
1462         my $phash = $format->{$key};
1463         if ($phash->{default_key}) {
1464             die "multiple default keys in schema ($default_key, $key)\n"
1465                 if defined($default_key);
1466             die "default key '$key' is an alias - this is not allowed\n"
1467                 if defined($phash->{alias});
1468             die "default key '$key' with keyAlias attribute is not allowed\n"
1469                 if $phash->{keyAlias};
1470             $default_key = $key;
1471         }
1472         my $key_alias = $phash->{keyAlias};
1473         die "found keyAlias without 'alias definition for '$key'\n"
1474             if $key_alias && !$phash->{alias};
1475
1476         if ($phash->{alias} && $key_alias) {
1477             die "inconsistent keyAlias '$key_alias' definition"
1478                 if defined($keyAliasProps->{$key_alias}) &&
1479                 $keyAliasProps->{$key_alias} ne $phash->{alias};
1480             $keyAliasProps->{$key_alias} = $phash->{alias};
1481         }
1482     }
1483
1484     return wantarray ? ($default_key, $keyAliasProps) : $default_key;
1485 };
1486
1487 sub generate_typetext {
1488     my ($format, $list_enums) = @_;
1489
1490     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1491
1492     my $res = '';
1493     my $add_sep = 0;
1494
1495     my $add_option_string = sub {
1496         my ($text, $optional) = @_;
1497
1498         if ($add_sep) {
1499             $text = ",$text";
1500             $res .= ' ';
1501         }
1502         $text = "[$text]" if $optional;
1503         $res .= $text;
1504         $add_sep = 1;
1505     };
1506
1507     my $format_key_value = sub {
1508         my ($key, $phash) = @_;
1509
1510         die "internal error" if defined($phash->{alias});
1511
1512         my $keytext = $key;
1513
1514         my $typetext = '';
1515
1516         if (my $desc = $phash->{format_description}) {
1517             $typetext .= "<$desc>";
1518         } elsif (my $text = $phash->{typetext}) {
1519             $typetext .= $text;
1520         } elsif (my $enum = $phash->{enum}) {
1521             if ($list_enums || (scalar(@$enum) <= 3)) {
1522                 $typetext .= '<' . join('|', @$enum) . '>';
1523             } else {
1524                 $typetext .= '<enum>';
1525             }
1526         } elsif ($phash->{type} eq 'boolean') {
1527             $typetext .= '<1|0>';
1528         } elsif ($phash->{type} eq 'integer') {
1529             $typetext .= '<integer>';
1530         } elsif ($phash->{type} eq 'number') {
1531             $typetext .= '<number>';
1532         } else {
1533             die "internal error: neither format_description nor typetext found for option '$key'";
1534         }
1535
1536         if (defined($default_key) && ($default_key eq $key)) {
1537             &$add_option_string("[$keytext=]$typetext", $phash->{optional});
1538         } else {
1539             &$add_option_string("$keytext=$typetext", $phash->{optional});
1540         }
1541     };
1542
1543     my $done = {};
1544
1545     my $cond_add_key = sub {
1546         my ($key) = @_;
1547
1548         return if $done->{$key}; # avoid duplicates
1549
1550         $done->{$key} = 1;
1551
1552         my $phash = $format->{$key};
1553
1554         return if !$phash; # should not happen
1555
1556         return if $phash->{alias};
1557
1558         &$format_key_value($key, $phash);
1559
1560     };
1561
1562     &$cond_add_key($default_key) if defined($default_key);
1563
1564     # add required keys first
1565     foreach my $key (sort keys %$format) {
1566         my $phash = $format->{$key};
1567         &$cond_add_key($key) if $phash && !$phash->{optional};
1568     }
1569
1570     # add the rest
1571     foreach my $key (sort keys %$format) {
1572         &$cond_add_key($key);
1573     }
1574
1575     foreach my $keyAlias (sort keys %$keyAliasProps) {
1576         &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
1577     }
1578
1579     return $res;
1580 }
1581
1582 sub print_property_string {
1583     my ($data, $format, $skip, $path) = @_;
1584
1585     if (ref($format) ne 'HASH') {
1586         my $schema = get_format($format);
1587         die "not a valid format: $format\n" if !$schema;
1588         $format = $schema;
1589     }
1590
1591     my $errors = {};
1592     check_object($path, $format, $data, undef, $errors);
1593     if (scalar(%$errors)) {
1594         raise "format error", errors => $errors;
1595     }
1596
1597     my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
1598
1599     my $res = '';
1600     my $add_sep = 0;
1601
1602     my $add_option_string = sub {
1603         my ($text) = @_;
1604
1605         $res .= ',' if $add_sep;
1606         $res .= $text;
1607         $add_sep = 1;
1608     };
1609
1610     my $format_value = sub {
1611         my ($key, $value, $format) = @_;
1612
1613         if (defined($format) && ($format eq 'disk-size')) {
1614             return format_size($value);
1615         } else {
1616             die "illegal value with commas for $key\n" if $value =~ /,/;
1617             return $value;
1618         }
1619     };
1620
1621     my $done = { map { $_ => 1 } @$skip };
1622
1623     my $cond_add_key = sub {
1624         my ($key, $isdefault) = @_;
1625
1626         return if $done->{$key}; # avoid duplicates
1627
1628         $done->{$key} = 1;
1629
1630         my $value = $data->{$key};
1631
1632         return if !defined($value);
1633
1634         my $phash = $format->{$key};
1635
1636         # try to combine values if we have key aliases
1637         if (my $combine = $keyAliasProps->{$key}) {
1638             if (defined(my $combine_value = $data->{$combine})) {
1639                 my $combine_format = $format->{$combine}->{format};
1640                 my $value_str = &$format_value($key, $value, $phash->{format});
1641                 my $combine_str = &$format_value($combine, $combine_value, $combine_format);
1642                 &$add_option_string("${value_str}=${combine_str}");
1643                 $done->{$combine} = 1;
1644                 return;
1645             }
1646         }
1647
1648         if ($phash && $phash->{alias}) {
1649             $phash = $format->{$phash->{alias}};
1650         }
1651
1652         die "invalid key '$key'\n" if !$phash;
1653         die "internal error" if defined($phash->{alias});
1654
1655         my $value_str = &$format_value($key, $value, $phash->{format});
1656         if ($isdefault) {
1657             &$add_option_string($value_str);
1658         } else {
1659             &$add_option_string("$key=${value_str}");
1660         }
1661     };
1662
1663     # add default key first
1664     &$cond_add_key($default_key, 1) if defined($default_key);
1665
1666     # add required keys first
1667     foreach my $key (sort keys %$data) {
1668         my $phash = $format->{$key};
1669         &$cond_add_key($key) if $phash && !$phash->{optional};
1670     }
1671
1672     # add the rest
1673     foreach my $key (sort keys %$data) {
1674         &$cond_add_key($key);
1675     }
1676
1677     return $res;
1678 }
1679
1680 sub schema_get_type_text {
1681     my ($phash, $style) = @_;
1682
1683     my $type = $phash->{type} || 'string';
1684
1685     if ($phash->{typetext}) {
1686         return $phash->{typetext};
1687     } elsif ($phash->{format_description}) {
1688         return "<$phash->{format_description}>";
1689     } elsif ($phash->{enum}) {
1690         return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
1691     } elsif ($phash->{pattern}) {
1692         return $phash->{pattern};
1693     } elsif ($type eq 'integer' || $type eq 'number') {
1694         # NOTE: always access values as number (avoid converion to string)
1695         if (defined($phash->{minimum}) && defined($phash->{maximum})) {
1696             return "<$type> (" . ($phash->{minimum} + 0) . " - " .
1697                 ($phash->{maximum} + 0) . ")";
1698         } elsif (defined($phash->{minimum})) {
1699             return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
1700         } elsif (defined($phash->{maximum})) {
1701             return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
1702         }
1703     } elsif ($type eq 'string') {
1704         if (my $format = $phash->{format}) {
1705             $format = get_format($format) if ref($format) ne 'HASH';
1706             if (ref($format) eq 'HASH') {
1707                 my $list_enums = 0;
1708                 $list_enums = 1 if $style && $style eq 'config-sub';
1709                 return generate_typetext($format, $list_enums);
1710             }
1711         }
1712     }
1713
1714     return "<$type>";
1715 }
1716
1717 1;