]>
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) ;
15 register_standard_option
19 # Note: This class implements something similar to JSON schema, but it is not 100% complete.
20 # see: http://tools.ietf.org/html/draft-zyp-json-schema-02
21 # see: http://json-schema.org/
23 # the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
25 my $standard_options = {};
26 sub register_standard_option
{
27 my ( $name, $schema ) = @_ ;
29 die "standard option ' $name ' already registered \n "
30 if $standard_options ->{ $name };
32 $standard_options ->{ $name } = $schema ;
35 sub get_standard_option
{
36 my ( $name, $base ) = @_ ;
38 my $std = $standard_options ->{ $name };
39 die "no such standard option \n " if ! $std ;
41 my $res = $base || {};
43 foreach my $opt ( keys %$std ) {
45 $res ->{ $opt } = $std ->{ $opt };
51 register_standard_option
( 'pve-vmid' , {
52 description
=> "The (unique) ID of the VM." ,
53 type
=> 'integer' , format
=> 'pve-vmid' ,
57 register_standard_option
( 'pve-node' , {
58 description
=> "The cluster node name." ,
59 type
=> 'string' , format
=> 'pve-node' ,
62 register_standard_option
( 'pve-node-list' , {
63 description
=> "List of cluster node names." ,
64 type
=> 'string' , format
=> 'pve-node-list' ,
67 register_standard_option
( 'pve-iface' , {
68 description
=> "Network interface name." ,
69 type
=> 'string' , format
=> 'pve-iface' ,
70 minLength
=> 2 , maxLength
=> 20 ,
73 PVE
:: JSONSchema
:: register_standard_option
( 'pve-storage-id' , {
74 description
=> "The storage identifier." ,
75 type
=> 'string' , format
=> 'pve-storage-id' ,
82 my ( $format, $code ) = @_ ;
84 die "JSON schema format ' $format ' already registered \n "
85 if $format_list ->{ $format };
87 $format_list ->{ $format } = $code ;
90 # register some common type for pve
92 register_format
( 'string' , sub {}); # allow format => 'string-list'
94 register_format
( 'pve-configid' , \
& pve_verify_configid
);
95 sub pve_verify_configid
{
96 my ( $id, $noerr ) = @_ ;
98 if ( $id !~ m/^[a-z][a-z0-9_]+$/i ) {
99 return undef if $noerr ;
100 die "invalid cofiguration ID ' $id ' \n " ;
105 PVE
:: JSONSchema
:: register_format
( 'pve-storage-id' , \
& parse_storage_id
);
106 sub parse_storage_id
{
107 my ( $storeid, $noerr ) = @_ ;
109 if ( $storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i ) {
110 return undef if $noerr ;
111 die "storage ID ' $storeid ' contains illegal characters \n " ;
117 register_format
( 'pve-vmid' , \
& pve_verify_vmid
);
118 sub pve_verify_vmid
{
119 my ( $vmid, $noerr ) = @_ ;
121 if ( $vmid !~ m/^[1-9][0-9]+$/ ) {
122 return undef if $noerr ;
123 die "value does not look like a valid VM ID \n " ;
128 register_format
( 'pve-node' , \
& pve_verify_node_name
);
129 sub pve_verify_node_name
{
130 my ( $node, $noerr ) = @_ ;
132 # todo: use better regex ?
133 if ( $node !~ m/^[A-Za-z][[:alnum:]\-]*[[:alnum:]]+$/ ) {
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 ( $ipv4 !~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ ||
145 !(( $1 > 0 ) && ( $1 < 255 ) &&
146 ( $2 <= 255 ) && ( $3 <= 255 ) &&
147 ( $4 > 0 ) && ( $4 < 255 ))) {
148 return undef if $noerr ;
149 die "value does not look like a valid IP address \n " ;
153 register_format
( 'ipv4mask' , \
& pve_verify_ipv4mask
);
154 sub pve_verify_ipv4mask
{
155 my ( $mask, $noerr ) = @_ ;
157 if ( $mask !~ m/^255\.255\.(\d{1,3})\.(\d{1,3})$/ ||
158 !(( $1 <= 255 ) && ( $2 <= 255 ))) {
159 return undef if $noerr ;
160 die "value does not look like a valid IP netmask \n " ;
165 register_format
( 'email' , \
& pve_verify_email
);
166 sub pve_verify_email
{
167 my ( $email, $noerr ) = @_ ;
169 # we use same regex as extjs Ext.form.VTypes.email
170 if ( $email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,6}$/ ) {
171 return undef if $noerr ;
172 die "value does not look like a valid email address \n " ;
177 # network interface name
178 register_format
( 'pve-iface' , \
& pve_verify_iface
);
179 sub pve_verify_iface
{
180 my ( $id, $noerr ) = @_ ;
182 if ( $id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i ) {
183 return undef if $noerr ;
184 die "invalid network interface name ' $id ' \n " ;
190 my ( $format, $value ) = @_ ;
192 return if $format eq 'regex' ;
194 if ( $format =~ m/^(.*)-a?list$/ ) {
196 my $code = $format_list ->{ $1 };
198 die "undefined format ' $format ' \n " if ! $code ;
200 # Note: we allow empty lists
201 foreach my $v ( split_list
( $value )) {
205 } elsif ( $format =~ m/^(.*)-opt$/ ) {
207 my $code = $format_list ->{ $1 };
209 die "undefined format ' $format ' \n " if ! $code ;
211 return if ! $value ; # allow empty string
217 my $code = $format_list ->{ $format };
219 die "undefined format ' $format ' \n " if ! $code ;
226 my ( $errors, $path, $msg ) = @_ ;
228 $path = '_root' if ! $path ;
230 if ( $errors ->{ $path }) {
231 $errors ->{ $path } = join ( ' \n ' , $errors ->{ $path }, $msg );
233 $errors ->{ $path } = $msg ;
240 # see 'man perlretut'
241 return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ ;
247 return $value =~ m/^[+-]?\d+$/ ;
251 my ( $path, $type, $value, $errors ) = @_ ;
255 if (! defined ( $value )) {
256 return 1 if $type eq 'null' ;
260 if ( my $tt = ref ( $type )) {
261 if ( $tt eq 'ARRAY' ) {
262 foreach my $t ( @$type ) {
264 check_type
( $path, $t, $value, $tmperr );
265 return 1 if ! scalar ( %$tmperr );
267 my $ttext = join ( '|' , @$type );
268 add_error
( $errors, $path, "type check (' $ttext ') failed" );
270 } elsif ( $tt eq 'HASH' ) {
272 check_prop
( $value, $type, $path, $tmperr );
273 return 1 if ! scalar ( %$tmperr );
274 add_error
( $errors, $path, "type check failed" );
277 die "internal error - got reference type ' $tt '" ;
282 return 1 if $type eq 'any' ;
284 if ( $type eq 'null' ) {
285 if ( defined ( $value )) {
286 add_error
( $errors, $path, "type check (' $type ') failed - value is not null" );
292 my $vt = ref ( $value );
294 if ( $type eq 'array' ) {
295 if (! $vt || $vt ne 'ARRAY' ) {
296 add_error
( $errors, $path, "type check (' $type ') failed" );
300 } elsif ( $type eq 'object' ) {
301 if (! $vt || $vt ne 'HASH' ) {
302 add_error
( $errors, $path, "type check (' $type ') failed" );
306 } elsif ( $type eq 'coderef' ) {
307 if (! $vt || $vt ne 'CODE' ) {
308 add_error
( $errors, $path, "type check (' $type ') failed" );
314 add_error
( $errors, $path, "type check (' $type ') failed - got $vt " );
317 if ( $type eq 'string' ) {
318 return 1 ; # nothing to check ?
319 } elsif ( $type eq 'boolean' ) {
320 #if ($value =~ m/^(1|true|yes|on)$/i) {
323 #} elsif ($value =~ m/^(0|false|no|off)$/i) {
324 } elsif ( $value eq '0' ) {
327 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
330 } elsif ( $type eq 'integer' ) {
331 if (! is_integer
( $value )) {
332 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
336 } elsif ( $type eq 'number' ) {
337 if (! is_number
( $value )) {
338 add_error
( $errors, $path, "type check (' $type ') failed - got ' $value '" );
343 return 1 ; # no need to verify unknown types
353 my ( $path, $schema, $value, $additional_properties, $errors ) = @_ ;
355 # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
357 my $st = ref ( $schema );
358 if (! $st || $st ne 'HASH' ) {
359 add_error
( $errors, $path, "Invalid schema definition." );
363 my $vt = ref ( $value );
364 if (! $vt || $vt ne 'HASH' ) {
365 add_error
( $errors, $path, "an object is required" );
369 foreach my $k ( keys %$schema ) {
370 check_prop
( $value ->{ $k }, $schema ->{ $k }, $path ?
" $path . $k " : $k, $errors );
373 foreach my $k ( keys %$value ) {
375 my $newpath = $path ?
" $path . $k " : $k ;
377 if ( my $subschema = $schema ->{ $k }) {
378 if ( my $requires = $subschema ->{ requires
}) {
379 if ( ref ( $requires )) {
380 #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
381 check_prop
( $value, $requires, $path, $errors );
382 } elsif (! defined ( $value ->{ $requires })) {
383 add_error
( $errors, $path ?
" $path . $requires " : $requires,
384 "missing property - ' $newpath ' requiers this property" );
388 next ; # value is already checked above
391 if ( defined ( $additional_properties ) && ! $additional_properties ) {
392 add_error
( $errors, $newpath, "property is not defined in schema " .
393 "and the schema does not allow additional properties" );
396 check_prop
( $value ->{ $k }, $additional_properties, $newpath, $errors )
397 if ref ( $additional_properties );
402 my ( $value, $schema, $path, $errors ) = @_ ;
404 die "internal error - no schema" if ! $schema ;
405 die "internal error" if ! $errors ;
407 #print "check_prop $path\n" if $value;
409 my $st = ref ( $schema );
410 if (! $st || $st ne 'HASH' ) {
411 add_error
( $errors, $path, "Invalid schema definition." );
415 # if it extends another schema, it must pass that schema as well
416 if ( $schema ->{ extends
}) {
417 check_prop
( $value, $schema ->{ extends
}, $path, $errors );
420 if (! defined ( $value )) {
421 return if $schema ->{ type
} && $schema ->{ type
} eq 'null' ;
422 if (! $schema ->{ optional
}) {
423 add_error
( $errors, $path, "property is missing and it is not optional" );
428 return if ! check_type
( $path, $schema ->{ type
}, $value, $errors );
430 if ( $schema ->{ disallow
}) {
432 if ( check_type
( $path, $schema ->{ disallow
}, $value, $tmperr )) {
433 add_error
( $errors, $path, "disallowed value was matched" );
438 if ( my $vt = ref ( $value )) {
440 if ( $vt eq 'ARRAY' ) {
441 if ( $schema ->{ items
}) {
442 my $it = ref ( $schema ->{ items
});
443 if ( $it && $it eq 'ARRAY' ) {
444 #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
445 die "not implemented" ;
448 foreach my $el ( @$value ) {
449 check_prop
( $el, $schema ->{ items
}, "${path}[ $ind ]" , $errors );
455 } elsif ( $schema ->{ properties
} || $schema ->{ additionalProperties
}) {
456 check_object
( $path, defined ( $schema ->{ properties
}) ?
$schema ->{ properties
} : {},
457 $value, $schema ->{ additionalProperties
}, $errors );
463 if ( my $format = $schema ->{ format
}) {
464 eval { check_format
( $format, $value ); };
466 add_error
( $errors, $path, "invalid format - $@ " );
471 if ( my $pattern = $schema ->{ pattern
}) {
472 if ( $value !~ m/^$pattern$/ ) {
473 add_error
( $errors, $path, "value does not match the regex pattern" );
478 if ( defined ( my $max = $schema ->{ maxLength
})) {
479 if ( length ( $value ) > $max ) {
480 add_error
( $errors, $path, "value may only be $max characters long" );
485 if ( defined ( my $min = $schema ->{ minLength
})) {
486 if ( length ( $value ) < $min ) {
487 add_error
( $errors, $path, "value must be at least $min characters long" );
492 if ( is_number
( $value )) {
493 if ( defined ( my $max = $schema ->{ maximum
})) {
495 add_error
( $errors, $path, "value must have a maximum value of $max " );
500 if ( defined ( my $min = $schema ->{ minimum
})) {
502 add_error
( $errors, $path, "value must have a minimum value of $min " );
508 if ( my $ea = $schema ->{ enum
}) {
511 foreach my $ev ( @$ea ) {
518 add_error
( $errors, $path, "value ' $value ' does not have a value in the enumeration '" .
519 join ( ", " , @$ea ) . "'" );
526 my ( $instance, $schema, $errmsg ) = @_ ;
529 $errmsg = "Parameter verification failed. \n " if ! $errmsg ;
531 # todo: cycle detection is only needed for debugging, I guess
532 # we can disable that in the final release
533 # todo: is there a better/faster way to detect cycles?
535 find_cycle
( $instance, sub { $cycles = 1 });
537 add_error
( $errors, undef , "data structure contains recursive cycles" );
539 check_prop
( $instance, $schema, '' , $errors );
542 if ( scalar ( %$errors )) {
543 raise
$errmsg, code
=> HTTP_BAD_REQUEST
, errors
=> $errors ;
549 my $schema_valid_types = [ "string" , "object" , "coderef" , "array" , "boolean" , "number" , "integer" , "null" , "any" ];
550 my $default_schema_noref = {
551 description
=> "This is the JSON Schema for JSON Schemas." ,
552 type
=> [ "object" ],
553 additionalProperties
=> 0 ,
556 type
=> [ "string" , "array" ],
557 description
=> "This is a type definition value. This can be a simple type, or a union type" ,
562 enum
=> $schema_valid_types,
564 enum
=> $schema_valid_types,
568 description
=> "This indicates that the instance property in the instance object is not required." ,
574 description
=> "This is a definition for the properties of an object value" ,
580 description
=> "When the value is an array, this indicates the schema to use to validate each item in an array" ,
584 additionalProperties
=> {
585 type
=> [ "boolean" , "object" ],
586 description
=> "This provides a default property definition for all properties that are not explicitly defined in an object type definition." ,
593 description
=> "This indicates the minimum value for the instance property when the type of the instance value is a number." ,
598 description
=> "This indicates the maximum value for the instance property when the type of the instance value is a number." ,
602 description
=> "When the instance value is a string, this indicates minimum length of the string" ,
609 description
=> "When the instance value is a string, this indicates maximum length of the string." ,
615 description
=> "A text representation of the type (used to generate documentation)." ,
620 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." ,
628 description
=> "This provides an enumeration of possible values that are valid for the instance property." ,
633 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)." ,
638 description
=> "This provides the title of the property" ,
641 type
=> [ "string" , "object" ],
643 description
=> "indicates a required property or a schema that must be validated if this property is present" ,
648 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" ,
653 description
=> "This indicates the default for the instance property."
658 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." ,
663 description
=> "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also." ,
666 # this is from hyper schema
669 description
=> "This defines the link relations of the instance objects" ,
676 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" ,
680 description
=> "This is the name of the link relation" ,
686 description
=> "For submission links, this defines the method that should be used to access the target resource" ,
696 my $default_schema = Storable
:: dclone
( $default_schema_noref );
698 $default_schema ->{ properties
}->{ properties
}->{ additionalProperties
} = $default_schema ;
699 $default_schema ->{ properties
}->{ additionalProperties
}->{ properties
} = $default_schema ->{ properties
};
701 $default_schema ->{ properties
}->{ items
}->{ properties
} = $default_schema ->{ properties
};
702 $default_schema ->{ properties
}->{ items
}->{ additionalProperties
} = 0 ;
704 $default_schema ->{ properties
}->{ disallow
}->{ properties
} = $default_schema ->{ properties
};
705 $default_schema ->{ properties
}->{ disallow
}->{ additionalProperties
} = 0 ;
707 $default_schema ->{ properties
}->{ requires
}->{ properties
} = $default_schema ->{ properties
};
708 $default_schema ->{ properties
}->{ requires
}->{ additionalProperties
} = 0 ;
710 $default_schema ->{ properties
}->{ extends
}->{ properties
} = $default_schema ->{ properties
};
711 $default_schema ->{ properties
}->{ extends
}->{ additionalProperties
} = 0 ;
713 my $method_schema = {
715 additionalProperties
=> 0 ,
718 description
=> "This a description of the method" ,
723 description
=> "This indicates the name of the function to call." ,
726 additionalProperties
=> 1 ,
741 description
=> "The HTTP method name." ,
742 enum
=> [ 'GET' , 'POST' , 'PUT' , 'DELETE' ],
747 description
=> "Method needs special privileges - only pvedaemon can execute it" ,
752 description
=> "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter." ,
757 description
=> "Required access permissions. By default only 'root' is allowed to access this method." ,
759 additionalProperties
=> 0 ,
762 description
=> "Describe access permissions." ,
766 description
=> "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials." ,
768 enum
=> [ 'all' , 'world' ],
772 description
=> "Array of permission checks (prefix notation)." ,
779 description
=> "Used internally" ,
783 description
=> "Used internally" ,
788 description
=> "path for URL matching (uri template)" ,
790 fragmentDelimiter
=> {
792 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." ,
797 description
=> "JSON Schema for parameters." ,
802 description
=> "JSON Schema for return value." ,
807 description
=> "method implementaion (code reference)" ,
812 description
=> "Delegate call to this class (perl class string)." ,
815 additionalProperties
=> 0 ,
821 fragmentDelimiter
=> { optional
=> 1 }
829 sub validate_schema
{
832 my $errmsg = "internal error - unable to verify schema \n " ;
833 validate
( $schema, $default_schema, $errmsg );
836 sub validate_method_info
{
839 my $errmsg = "internal error - unable to verify method info \n " ;
840 validate
( $info, $method_schema, $errmsg );
842 validate_schema
( $info ->{ parameters
}) if $info ->{ parameters
};
843 validate_schema
( $info ->{ returns
}) if $info ->{ returns
};
846 # run a self test on load
847 # make sure we can verify the default schema
848 validate_schema
( $default_schema_noref );
849 validate_schema
( $method_schema );
851 # and now some utility methods (used by pve api)
852 sub method_get_child_link
{
855 return undef if ! $info ;
857 my $schema = $info ->{ returns
};
858 return undef if ! $schema || ! $schema ->{ type
} || $schema ->{ type
} ne 'array' ;
860 my $links = $schema ->{ links
};
861 return undef if ! $links ;
864 foreach my $lnk ( @$links ) {
865 if ( $lnk ->{ href
} && $lnk ->{ rel
} && ( $lnk ->{ rel
} eq 'child' )) {
874 # a way to parse command line parameters, using a
875 # schema to configure Getopt::Long
877 my ( $schema, $args, $arg_param, $fixed_param, $pwcallback ) = @_ ;
879 if (! $schema || ! $schema ->{ properties
}) {
880 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
881 if scalar ( @$args ) != 0 ;
886 if ( $arg_param && ! ref ( $arg_param )) {
887 my $pd = $schema ->{ properties
}->{ $arg_param };
888 die "expected list format $pd ->{format}"
889 if !( $pd && $pd ->{ format
} && $pd ->{ format
} =~ m/-list/ );
890 $list_param = $arg_param ;
894 foreach my $prop ( keys %{ $schema ->{ properties
}}) {
895 my $pd = $schema ->{ properties
}->{ $prop };
896 next if $list_param && $prop eq $list_param ;
897 next if defined ( $fixed_param ->{ $prop });
899 if ( $prop eq 'password' && $pwcallback ) {
900 # we do not accept plain password on input line, instead
901 # we turn this into a boolean option and ask for password below
902 # using $pwcallback() (for security reasons).
903 push @getopt, " $prop " ;
904 } elsif ( $pd ->{ type
} eq 'boolean' ) {
905 push @getopt, " $prop :s" ;
907 if ( $pd ->{ format
} && $pd ->{ format
} =~ m/-a?list/ ) {
908 push @getopt, " $prop =s@" ;
910 push @getopt, " $prop =s" ;
916 raise
( "unable to parse option \n " , code
=> HTTP_BAD_REQUEST
)
917 if ! Getopt
:: Long
:: GetOptionsFromArray
( $args, $opts, @getopt );
919 if ( my $acount = scalar ( @$args )) {
921 $opts ->{ $list_param } = $args ;
923 } elsif ( ref ( $arg_param )) {
924 raise
( "wrong number of arguments \n " , code
=> HTTP_BAD_REQUEST
)
925 if scalar ( @$arg_param ) != $acount ;
926 foreach my $p ( @$arg_param ) {
927 $opts ->{ $p } = shift @$args ;
930 raise
( "too many arguments \n " , code
=> HTTP_BAD_REQUEST
)
931 if scalar ( @$args ) != 0 ;
935 if ( my $pd = $schema ->{ properties
}->{ password
}) {
936 if ( $pd ->{ type
} ne 'boolean' && $pwcallback ) {
937 if ( $opts ->{ password
} || ! $pd ->{ optional
}) {
938 $opts ->{ password
} = & $pwcallback ();
943 $opts = PVE
:: Tools
:: decode_utf8_parameters
( $opts );
944 if ( $opts ->{ description
}) {
945 print "TEST: " . PVE
:: Tools
:: encode_text
( $opts ->{ description
}) . " \n " ;
948 foreach my $p ( keys %$opts ) {
949 if ( my $pd = $schema ->{ properties
}->{ $p }) {
950 if ( $pd ->{ type
} eq 'boolean' ) {
951 if ( $opts ->{ $p } eq '' ) {
953 } elsif ( $opts ->{ $p } =~ m/^(1|true|yes|on)$/i ) {
955 } elsif ( $opts ->{ $p } =~ m/^(0|false|no|off)$/i ) {
958 raise
( "unable to parse boolean option \n " , code
=> HTTP_BAD_REQUEST
);
960 } elsif ( $pd ->{ format
}) {
962 if ( $pd ->{ format
} =~ m/-list/ ) {
963 # allow --vmid 100 --vmid 101 and --vmid 100,101
964 # allow --dow mon --dow fri and --dow mon,fri
965 $opts ->{ $p } = join ( "," , @{ $opts ->{ $p }});
966 } elsif ( $pd ->{ format
} =~ m/-alist/ ) {
967 # we encode array as \0 separated strings
968 # Note: CGI.pm also use this encoding
969 if ( scalar (@{ $opts ->{ $p }}) != 1 ) {
970 $opts ->{ $p } = join ( "\0" , @{ $opts ->{ $p }});
972 # st that split_list knows it is \0 terminated
973 my $v = $opts ->{ $p }->[ 0 ];
974 $opts ->{ $p } = " $v\0 " ;
981 foreach my $p ( keys %$fixed_param ) {
982 $opts ->{ $p } = $fixed_param ->{ $p };
988 # A way to parse configuration data by giving a json schema
990 my ( $schema, $filename, $raw ) = @_ ;
992 # do fast check (avoid validate_schema($schema))
993 die "got strange schema" if ! $schema ->{ type
} ||
994 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
998 while ( $raw && $raw =~ s/^(.*?)(\n|$)// ) {
1001 next if $line =~ m/^\#/ ; # skip comment lines
1002 next if $line =~ m/^\s*$/ ; # skip empty lines
1004 if ( $line =~ m/^(\S+):\s*(\S+)\s*$/ ) {
1007 if ( $schema ->{ properties
}->{ $key } &&
1008 $schema ->{ properties
}->{ $key }->{ type
} eq 'boolean' ) {
1010 $value = 1 if $value =~ m/^(1|on|yes|true)$/i ;
1011 $value = 0 if $value =~ m/^(0|off|no|false)$/i ;
1013 $cfg ->{ $key } = $value ;
1015 warn "ignore config line: $line\n "
1020 check_prop
( $cfg, $schema, '' , $errors );
1022 foreach my $k ( keys %$errors ) {
1023 warn "parse error in ' $filename ' - ' $k ': $errors ->{ $k } \n " ;
1030 # generate simple key/value file
1032 my ( $schema, $filename, $cfg ) = @_ ;
1034 # do fast check (avoid validate_schema($schema))
1035 die "got strange schema" if ! $schema ->{ type
} ||
1036 ! $schema ->{ properties
} || $schema ->{ type
} ne 'object' ;
1038 validate
( $cfg, $schema, "validation error in ' $filename ' \n " );
1042 foreach my $k ( keys %$cfg ) {
1043 $data .= " $k : $cfg ->{ $k } \n " ;