]>
git.proxmox.com Git - pve-common.git/blob - data/PVE/JSONSchema.pm
1 package PVE
:: JSONSchema
;
5 use Storable
; # for dclone
7 use Devel
:: Cycle
- quiet
; # todo: remove?
8 use PVE
:: Tools
qw(split_list) ;
9 use PVE
:: Exception
qw(raise) ;
10 use HTTP
:: Status
qw(:constants) ;
11 use Net
:: IP
qw(:PROC) ;
16 register_standard_option
20 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
21 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
22 # see: http://json-schema.org/
24 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
26 my $standard_options = {};
27 sub register_standard_option
{
28 my ( $name, $schema ) = @_ ;
30 die "standard option ' $name ' already registered \n "
31 if $standard_options ->{ $name };
33 $standard_options ->{ $name } = $schema ;
36 sub get_standard_option
{
37 my ( $name, $base ) = @_ ;
39 my $std = $standard_options ->{ $name };
40 die "no such standard option \n " if ! $std ;
42 my $res = $base || {};
44 foreach my $opt ( keys %$std ) {
46 $res ->{ $opt } = $std ->{ $opt };
52 register_standard_option
( 'pve-vmid' , {
53 description
=> "The (unique) ID of the VM." ,
54 type
=> 'integer' , format
=> 'pve-vmid' ,
58 register_standard_option
( 'pve-node' , {
59 description
=> "The cluster node name." ,
60 type
=> 'string' , format
=> 'pve-node' ,
63 register_standard_option
( 'pve-node-list' , {
64 description
=> "List of cluster node names." ,
65 type
=> 'string' , format
=> 'pve-node-list' ,
68 register_standard_option
( 'pve-iface' , {
69 description
=> "Network interface name." ,
70 type
=> 'string' , format
=> 'pve-iface' ,
71 minLength
=> 2 , maxLength
=> 20 ,
74 PVE
:: JSONSchema
:: register_standard_option
( 'pve-storage-id' , {
75 description
=> "The storage identifier." ,
76 type
=> 'string' , format
=> 'pve-storage-id' ,
83 my ( $format, $code ) = @_ ;
85 die "JSON schema format ' $format ' already registered \n "
86 if $format_list ->{ $format };
88 $format_list ->{ $format } = $code ;
91 # register some common type for pve
93 register_format
( 'string' , sub {}); # allow format => 'string-list'
95 register_format
( 'pve-configid' , \
& pve_verify_configid
);
96 sub pve_verify_configid
{
97 my ( $id, $noerr ) = @_ ;
99 if ( $id !~ m/^[a-z][a-z0-9_]+$/i ) {
100 return undef if $noerr ;
101 die "invalid configuration ID ' $id ' \n " ;
106 PVE
:: JSONSchema
:: register_format
( 'pve-storage-id' , \
& parse_storage_id
);
107 sub parse_storage_id
{
108 my ( $storeid, $noerr ) = @_ ;
110 if ( $storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
111 return undef if $noerr ;
112 die "storage ID ' $storeid ' contains illegal characters \n " ;
118 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
119 sub pve_verify_vmid
{
120 my ( $vmid, $noerr ) = @_ ;
122 if ( $vmid !~ m/^[1-9][0-9]+$/ ) {
123 return undef if $noerr ;
124 die "value does not look like a valid VM ID \n " ;
129 register_format
( 'pve-node' , \
& pve_verify_node_name
);
130 sub pve_verify_node_name
{
131 my ( $node, $noerr ) = @_ ;
133 if ( $node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/ ) {
134 return undef if $noerr ;
135 die "value does not look like a valid node name \n " ;
140 register_format
( 'ipv4' , \
& pve_verify_ipv4
);
141 sub pve_verify_ipv4
{
142 my ( $ipv4, $noerr ) = @_ ;
144 if (! Net
:: IP
:: ip_is_ipv4
( $ipv4 )) {
145 return undef if $noerr ;
146 die "value does not look like a valid IP address \n " ;
151 my $ipv4_mask_hash = {
168 '255.255.128.0' => 17 ,
169 '255.255.192.0' => 18 ,
170 '255.255.224.0' => 19 ,
171 '255.255.240.0' => 20 ,
172 '255.255.248.0' => 21 ,
173 '255.255.252.0' => 22 ,
174 '255.255.254.0' => 23 ,
175 '255.255.255.0' => 24 ,
176 '255.255.255.128' => 25 ,
177 '255.255.255.192' => 26 ,
178 '255.255.255.224' => 27 ,
179 '255.255.255.240' => 28 ,
180 '255.255.255.248' => 29 ,
181 '255.255.255.252' => 30
184 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
185 sub pve_verify_ipv4mask
{
186 my ( $mask, $noerr ) = @_ ;
188 if (! defined ( $ipv4_mask_hash ->{ $mask })) {
189 return undef if $noerr ;
190 die "value does not look like a valid IP netmask \n " ;
195 register_format
( 'email' , \
& pve_verify_email
);
196 sub pve_verify_email
{
197 my ( $email, $noerr ) = @_ ;
199 # we use same regex as extjs Ext.form.VTypes.email
200 if ( $email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,6}$/ ) {
201 return undef if $noerr ;
202 die "value does not look like a valid email address \n " ;
207 register_format
( 'dns-name' , \
& pve_verify_dns_name
);
208 sub pve_verify_dns_name
{
209 my ( $name, $noerr ) = @_ ;
211 my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)" ;
213 if ( $name !~ /^(${namere}\.)*${namere}$/ ) {
214 return undef if $noerr ;
215 die "value does not look like a valid DNS name \n " ;
220 # network interface name
221 register_format
( 'pve-iface' , \
& pve_verify_iface
);
222 sub pve_verify_iface
{
223 my ( $id, $noerr ) = @_ ;
225 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
226 return undef if $noerr ;
227 die "invalid network interface name ' $id ' \n " ;
233 my ( $format, $value ) = @_ ;
235 return if $format eq 'regex' ;
237 if ( $format =~ m/^(.*)-a?list$/ ) {
239 my $code = $format_list ->{ $1 };
241 die "undefined format ' $format ' \n " if ! $code ;
243 # Note: we allow empty lists
244 foreach my $v ( split_list
( $value )) {
248 } elsif ( $format =~ m/^(.*)-opt$/ ) {
250 my $code = $format_list ->{ $1 };
252 die "undefined format ' $format ' \n " if ! $code ;
254 return if ! $value ; # allow empty string
260 my $code = $format_list ->{ $format };
262 die "undefined format ' $format ' \n " if ! $code ;
269 my ( $errors, $path, $msg ) = @_ ;
271 $path = '_root' if ! $path ;
273 if ( $errors ->{ $path }) {
274 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
276 $errors ->{ $path } = $msg ;
283 # see 'man perlretut'
284 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
290 return $value =~ m/^[+-]?\d+$/ ;
294 my ( $path, $type, $value, $errors ) = @_ ;
298 if (! defined ( $value )) {
299 return 1 if $type eq 'null' ;
303 if ( my $tt = ref ( $type )) {
304 if ( $tt eq 'ARRAY' ) {
305 foreach my $t ( @$type ) {
307 check_type
( $path, $t, $value, $tmperr );
308 return 1 if ! scalar ( %$tmperr );
310 my $ttext = join ( '|' , @$type );
311 add_error
( $errors, $path, "type check (' $ttext ') failed" );
313 } elsif ( $tt eq 'HASH' ) {
315 check_prop
( $value, $type, $path, $tmperr );
316 return 1 if ! scalar ( %$tmperr );
317 add_error
( $errors, $path, "type check failed" );
320 die "internal error - got reference type ' $tt '" ;
325 return 1 if $type eq 'any' ;
327 if ( $type eq 'null' ) {
328 if ( defined ( $value )) {
329 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
335 my $vt = ref ( $value );
337 if ( $type eq 'array' ) {
338 if (! $vt || $vt ne 'ARRAY' ) {
339 add_error
( $errors, $path, "type check (' $type ') failed" );
343 } elsif ( $type eq 'object' ) {
344 if (! $vt || $vt ne 'HASH' ) {
345 add_error
( $errors, $path, "type check (' $type ') failed" );
349 } elsif ( $type eq 'coderef' ) {
350 if (! $vt || $vt ne 'CODE' ) {
351 add_error
( $errors, $path, "type check (' $type ') failed" );
357 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
360 if ( $type eq 'string' ) {
361 return 1 ; # nothing to check ?
362 } elsif ( $type eq 'boolean' ) {
363 #if ($value =~ m/^(1|true|yes|on)$/i) {
366 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
367 } elsif ( $value eq '0' ) {
370 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
373 } elsif ( $type eq 'integer' ) {
374 if (! is_integer
( $value )) {
375 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
379 } elsif ( $type eq 'number' ) {
380 if (! is_number
( $value )) {
381 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
386 return 1 ; # no need to verify unknown types
396 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
398 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
400 my $st = ref ( $schema );
401 if (! $st || $st ne 'HASH' ) {
402 add_error
( $errors, $path, "Invalid schema definition." );
406 my $vt = ref ( $value );
407 if (! $vt || $vt ne 'HASH' ) {
408 add_error
( $errors, $path, "an object is required" );
412 foreach my $k ( keys %$schema ) {
413 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
416 foreach my $k ( keys %$value ) {
418 my $newpath = $path ?
" $path . $k " : $k ;
420 if ( my $subschema = $schema ->{ $k }) {
421 if ( my $requires = $subschema ->{ requires
}) {
422 if ( ref ( $requires )) {
423 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
424 check_prop
( $value, $requires, $path, $errors );
425 } elsif (! defined ( $value ->{ $requires })) {
426 add_error
( $errors, $path ?
" $path . $requires " : $requires,
427 "missing property - ' $newpath ' requiers this property" );
431 next ; # value is already checked above
434 if ( defined ( $additional_properties ) && ! $additional_properties ) {
435 add_error
( $errors, $newpath, "property is not defined in schema " .
436 "and the schema does not allow additional properties" );
439 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
440 if ref ( $additional_properties );
445 my ( $value, $schema, $path, $errors ) = @_ ;
447 die "internal error - no schema" if ! $schema ;
448 die "internal error" if ! $errors ;
450 #print "check_prop $path\n" if $value;
452 my $st = ref ( $schema );
453 if (! $st || $st ne 'HASH' ) {
454 add_error
( $errors, $path, "Invalid schema definition." );
458 # if it extends another schema, it must pass that schema as well
459 if ( $schema ->{ extends
}) {
460 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
463 if (! defined ( $value )) {
464 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
465 if (! $schema ->{ optional
}) {
466 add_error
( $errors, $path, "property is missing and it is not optional" );
471 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
473 if ( $schema ->{ disallow
}) {
475 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
476 add_error
( $errors, $path, "disallowed value was matched" );
481 if ( my $vt = ref ( $value )) {
483 if ( $vt eq 'ARRAY' ) {
484 if ( $schema ->{ items
}) {
485 my $it = ref ( $schema ->{ items
});
486 if ( $it && $it eq 'ARRAY' ) {
487 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
488 die "not implemented" ;
491 foreach my $el ( @$value ) {
492 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
498 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
499 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
500 $value, $schema ->{ additionalProperties
}, $errors );
506 if ( my $format = $schema ->{ format
}) {
507 eval { check_format
( $format, $value ); };
509 add_error
( $errors, $path, "invalid format - $@ " );
514 if ( my $pattern = $schema ->{ pattern
}) {
515 if ( $value !~ m/^$pattern$/ ) {
516 add_error
( $errors, $path, "value does not match the regex pattern" );
521 if ( defined ( my $max = $schema ->{ maxLength
})) {
522 if ( length ( $value ) > $max ) {
523 add_error
( $errors, $path, "value may only be $max characters long" );
528 if ( defined ( my $min = $schema ->{ minLength
})) {
529 if ( length ( $value ) < $min ) {
530 add_error
( $errors, $path, "value must be at least $min characters long" );
535 if ( is_number
( $value )) {
536 if ( defined ( my $max = $schema ->{ maximum
})) {
538 add_error
( $errors, $path, "value must have a maximum value of $max " );
543 if ( defined ( my $min = $schema ->{ minimum
})) {
545 add_error
( $errors, $path, "value must have a minimum value of $min " );
551 if ( my $ea = $schema ->{ enum
}) {
554 foreach my $ev ( @$ea ) {
561 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
562 join ( ", " , @$ea ) . "'" );
569 my ( $instance, $schema, $errmsg ) = @_ ;
572 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
574 # todo: cycle detection is only needed for debugging, I guess
575 # we can disable that in the final release
576 # todo: is there a better/faster way to detect cycles?
578 find_cycle
( $instance, sub { $cycles = 1 });
580 add_error
( $errors, undef , "data structure contains recursive cycles" );
582 check_prop
( $instance, $schema, '' , $errors );
585 if ( scalar ( %$errors )) {
586 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
592 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
593 my $default_schema_noref = {
594 description
=> "This is the JSON Schema for JSON Schemas." ,
595 type
=> [ "object" ],
596 additionalProperties
=> 0 ,
599 type
=> [ "string" , "array" ],
600 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
605 enum
=> $schema_valid_types,
607 enum
=> $schema_valid_types,
611 description
=> "This indicates that the instance property in the instance object is not required." ,
617 description
=> "This is a definition for the properties of an object value" ,
623 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
627 additionalProperties
=> {
628 type
=> [ "boolean" , "object" ],
629 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
636 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
641 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
645 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
652 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
658 description
=> "A text representation of the type (used to generate documentation)." ,
663 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." ,
671 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
676 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)." ,
681 description
=> "This provides the title of the property" ,
684 type
=> [ "string" , "object" ],
686 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
691 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" ,
696 description
=> "This indicates the default for the instance property."
701 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, than this instance is not valid." ,
706 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
709 # this is from hyper schema
712 description
=> "This defines the link relations of the instance objects" ,
719 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" ,
723 description
=> "This is the name of the link relation" ,
729 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
739 my $default_schema = Storable
:: dclone
( $default_schema_noref );
741 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
742 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
744 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
745 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
747 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
748 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
750 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
751 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
753 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
754 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
756 my $method_schema = {
758 additionalProperties
=> 0 ,
761 description
=> "This a description of the method" ,
766 description
=> "This indicates the name of the function to call." ,
769 additionalProperties
=> 1 ,
784 description
=> "The HTTP method name." ,
785 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
790 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
795 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
800 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
802 additionalProperties
=> 0 ,
805 description
=> "Describe access permissions." ,
809 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
811 enum
=> [ 'all' , 'world' ],
815 description
=> "Array of permission checks (prefix notation)." ,
822 description
=> "Used internally" ,
826 description
=> "Used internally" ,
831 description
=> "path for URL matching (uri template)" ,
833 fragmentDelimiter
=> {
835 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." ,
840 description
=> "JSON Schema for parameters." ,
845 description
=> "JSON Schema for return value." ,
850 description
=> "method implementaion (code reference)" ,
855 description
=> "Delegate call to this class (perl class string)." ,
858 additionalProperties
=> 0 ,
864 fragmentDelimiter
=> { optional
=> 1 }
872 sub validate_schema
{
875 my $errmsg = "internal error - unable to verify schema \n " ;
876 validate
( $schema, $default_schema, $errmsg );
879 sub validate_method_info
{
882 my $errmsg = "internal error - unable to verify method info \n " ;
883 validate
( $info, $method_schema, $errmsg );
885 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
886 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
889 # run a self test on load
890 # make sure we can verify the default schema
891 validate_schema
( $default_schema_noref );
892 validate_schema
( $method_schema );
894 # and now some utility methods (used by pve api)
895 sub method_get_child_link
{
898 return undef if ! $info ;
900 my $schema = $info ->{ returns
};
901 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
903 my $links = $schema ->{ links
};
904 return undef if ! $links ;
907 foreach my $lnk ( @$links ) {
908 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
917 # a way to parse command line parameters, using a
918 # schema to configure Getopt::Long
920 my ( $schema, $args, $arg_param, $fixed_param, $pwcallback ) = @_ ;
922 if (! $schema || ! $schema ->{ properties
}) {
923 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
924 if scalar ( @$args ) != 0 ;
929 if ( $arg_param && ! ref ( $arg_param )) {
930 my $pd = $schema ->{ properties
}->{ $arg_param };
931 die "expected list format $pd ->{format}"
932 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
933 $list_param = $arg_param ;
937 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
938 my $pd = $schema ->{ properties
}->{ $prop };
939 next if $list_param && $prop eq $list_param ;
940 next if defined ( $fixed_param ->{ $prop });
942 if ( $prop eq 'password' && $pwcallback ) {
943 # we do not accept plain password on input line, instead
944 # we turn this into a boolean option and ask for password below
945 # using $pwcallback() (for security reasons).
946 push @getopt, " $prop " ;
947 } elsif ( $pd ->{ type
} eq 'boolean' ) {
948 push @getopt, " $prop :s" ;
950 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
951 push @getopt, " $prop =s@" ;
953 push @getopt, " $prop =s" ;
959 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
960 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
962 if ( my $acount = scalar ( @$args )) {
964 $opts ->{ $list_param } = $args ;
966 } elsif ( ref ( $arg_param )) {
967 raise
( "wrong number of arguments \n " , code
=> HTTP_BAD_REQUEST
)
968 if scalar ( @$arg_param ) != $acount ;
969 foreach my $p ( @$arg_param ) {
970 $opts ->{ $p } = shift @$args ;
973 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
974 if scalar ( @$args ) != 0 ;
978 if ( my $pd = $schema ->{ properties
}->{ password
}) {
979 if ( $pd ->{ type
} ne 'boolean' && $pwcallback ) {
980 if ( $opts ->{ password
} || ! $pd ->{ optional
}) {
981 $opts ->{ password
} = & $pwcallback ();
986 $opts = PVE
:: Tools
:: decode_utf8_parameters
( $opts );
988 foreach my $p ( keys %$opts ) {
989 if ( my $pd = $schema ->{ properties
}->{ $p }) {
990 if ( $pd ->{ type
} eq 'boolean' ) {
991 if ( $opts ->{ $p } eq '' ) {
993 } elsif ( $opts ->{ $p } =~ m/^(1|true|yes|on)$/i ) {
995 } elsif ( $opts ->{ $p } =~ m/^(0|false|no|off)$/i ) {
998 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
1000 } elsif ( $pd ->{ format
}) {
1002 if ( $pd ->{ format
} =~ m/-list/ ) {
1003 # allow --vmid 100 --vmid 101 and --vmid 100,101
1004 # allow --dow mon --dow fri and --dow mon,fri
1005 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }});
1006 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
1007 # we encode array as \0 separated strings
1008 # Note: CGI.pm also use this encoding
1009 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
1010 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
1012 # st that split_list knows it is \0 terminated
1013 my $v = $opts ->{ $p }->[ 0 ];
1014 $opts ->{ $p } = " $v\0 " ;
1021 foreach my $p ( keys %$fixed_param ) {
1022 $opts ->{ $p } = $fixed_param ->{ $p };
1028 # A way to parse configuration data by giving a json schema
1030 my ( $schema, $filename, $raw ) = @_ ;
1032 # do fast check (avoid validate_schema($schema))
1033 die "got strange schema" if ! $schema ->{ type
} ||
1034 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1038 while ( $raw && $raw =~ s/^(.*?)(\n|$)// ) {
1041 next if $line =~ m/^\#/ ; # skip comment lines
1042 next if $line =~ m/^\s*$/ ; # skip empty lines
1044 if ( $line =~ m/^(\S+):\s*(\S+)\s*$/ ) {
1047 if ( $schema ->{ properties
}->{ $key } &&
1048 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1050 $value = 1 if $value =~ m/^(1|on|yes|true)$/i ;
1051 $value = 0 if $value =~ m/^(0|off|no|false)$/i ;
1053 $cfg ->{ $key } = $value ;
1055 warn "ignore config line: $line\n "
1060 check_prop
( $cfg, $schema, '' , $errors );
1062 foreach my $k ( keys %$errors ) {
1063 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1070 # generate simple key/value file
1072 my ( $schema, $filename, $cfg ) = @_ ;
1074 # do fast check (avoid validate_schema($schema))
1075 die "got strange schema" if ! $schema ->{ type
} ||
1076 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1078 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1082 foreach my $k ( keys %$cfg ) {
1083 $data .= " $k : $cfg ->{ $k } \n " ;