1 (* Copyright (C) 2004, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://helm.cs.unibo.it/
28 exception Malformed_key of string
29 exception Key_not_found of string
30 exception Type_error of string * string * string (* expected type, value, msg *)
31 exception Parse_error of string * int (* file, lineno *)
32 exception Invalid_value of (string * string) * string (* key, value, descr *)
34 exception Unescape_failure
36 type validator_id = int
38 let get_next_validator_id =
39 let next_id = ref 0 in
45 let validators = Hashtbl.create magic_size
46 let registry = Hashtbl.create magic_size
48 let backup_registry () = Hashtbl.copy registry
49 let restore_registry backup =
50 Hashtbl.clear registry;
51 Hashtbl.iter (fun key value -> Hashtbl.replace registry key value) backup
53 let valid_key_rex_raw = "\\w+(\\.\\w+)*"
54 let config_line_raw = sprintf "\\s*(%s)\\s*=\\s*\"(.*)\"\\s*" valid_key_rex_raw
55 let comment_rex = Pcre.regexp "^\\s*(#|$)"
56 let valid_key_rex = Pcre.regexp ("^" ^ valid_key_rex_raw ^ "$")
57 let config_line_rex = Pcre.regexp ("^" ^ config_line_raw ^ "$")
59 let is_comment s = Pcre.pmatch ~rex:comment_rex s
61 let escape = String.escaped
63 let lexer = lazy (Genlex.make_lexer []) in
65 let tok_stream = Lazy.force lexer (Stream.of_string ("\"" ^ s ^ "\"")) in
66 match Stream.peek tok_stream with
67 | Some (Genlex.String s) -> s
68 | _ -> raise Unescape_failure
70 let key_is_valid key =
71 if not (Pcre.pmatch ~rex:valid_key_rex key) then
72 raise (Malformed_key key)
74 let value_is_valid ~key ~value =
76 (fun (validator, descr) ->
77 if not (validator value) then
78 raise (Invalid_value ((key, value), descr)))
79 (Hashtbl.find_all validators key)
81 let set' registry ~key ~value =
83 value_is_valid ~key ~value;
84 Hashtbl.replace registry key value
89 Hashtbl.find registry key
90 with Not_found -> raise (Key_not_found key)
92 let set = set' registry
94 let string_list_of_string s =
95 (* trailing blanks are removed per default by Pcre.split *)
96 Pcre.split ~pat:"\\s+" (Pcre.replace ~pat:"^\\s+" s)
97 let string_of_string_list l = String.concat " " l
99 let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) =
101 let value = get key in
105 raise (Type_error (type_name, value, Printexc.to_string exn))
107 let setter ~key ~value = set ~key ~value:(to_string value) in
110 let (get_int, set_int) = mk_get_set "int" int_of_string string_of_int
111 let (get_float, set_float) = mk_get_set "float" float_of_string string_of_float
112 let (get_string_list, set_string_list) =
113 mk_get_set "string list" string_list_of_string string_of_string_list
116 let oc = open_out fname in
120 output_string oc (sprintf "%s = \"%s\"" key (escape value)))
127 let load_from fname =
128 let backup = backup_registry () in
129 Hashtbl.clear registry;
130 let ic = open_in fname in
131 let lineno = ref 0 in
135 let line = input_line ic in
136 if not (is_comment line) then
137 let subs = Pcre.extract ~rex:config_line_rex line in
138 let (key, value) = (subs.(1), unescape subs.(3)) in
142 | End_of_file -> close_in ic
143 | Malformed_key _ | Unescape_failure | Not_found ->
144 restore_registry backup;
145 raise (Parse_error (fname, !lineno))
148 restore_registry backup;
151 let add_validator ~key ~validator ~descr =
152 let id = get_next_validator_id () in
153 Hashtbl.add validators key (validator, descr);
158 let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry