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/
30 if debug then prerr_endline ("Helm_registry debugging: " ^ s)
35 let rec aux last_element = function
38 (match last_element with
39 | Some elt when elt = hd -> aux last_element tl
40 | _ -> hd :: aux (Some hd) tl)
44 let starts_with prefix =
46 let rex = Str.regexp (Str.quote prefix) in
47 fun s -> Str.string_match rex s 0
49 let prefix_len = String.length prefix in
52 String.sub s 0 prefix_len = prefix
53 with Invalid_argument _ -> false
55 let hashtbl_keys tbl = Hashtbl.fold (fun k _ acc -> k :: acc) tbl []
56 let hashtbl_pairs tbl = Hashtbl.fold (fun k v acc -> (k,v) :: acc) tbl []
60 exception Malformed_key of string
61 exception Key_not_found of string
62 exception Cyclic_definition of string
63 exception Type_error of string * string * string (* expected type, value, msg *)
64 exception Parse_error of string * int * int * string (* file, line, col, msg *)
65 exception Invalid_value of (string * string) * string (* key, value, descr *)
67 type validator_id = int
69 (* root XML tag: used by save_to, ignored by load_from *)
70 let root_tag = "helm_registry"
72 let get_next_validator_id =
73 let next_id = ref 0 in
79 let validators = Hashtbl.create magic_size
80 let registry = Hashtbl.create magic_size
82 let backup_registry () = Hashtbl.copy registry
83 let restore_registry backup =
84 Hashtbl.clear registry;
85 Hashtbl.iter (fun key value -> Hashtbl.replace registry key value) backup
88 * - no sequences of '_' longer than 1 are permitted
90 let valid_step_rex_raw = "[a-zA-Z0-9]+\\(_[a-z0A-Z-9]+\\)*"
91 let valid_key_rex_raw =
92 sprintf "%s\(\\.%s\)*" valid_step_rex_raw valid_step_rex_raw
93 let valid_key_rex = Str.regexp ("^" ^ valid_key_rex_raw ^ "$")
94 let interpolated_key_rex = Str.regexp ("\\$(" ^ valid_key_rex_raw ^ ")")
95 let dot_rex = Str.regexp "\\."
96 let spaces_rex = Str.regexp "[ \t\n\r]+"
97 let heading_spaces_rex = Str.regexp "^[ \t\n\r]+"
100 (* trailing blanks are removed per default by split *)
101 Str.split spaces_rex (Str.global_replace heading_spaces_rex "" s)
102 let merge l = String.concat " " l
104 (* escapes for xml configuration file *)
105 let (escape, unescape) =
106 let (in_enc, out_enc) = (`Enc_utf8, `Enc_utf8) in
107 (Netencoding.Html.encode ~in_enc ~out_enc (),
108 Netencoding.Html.decode ~in_enc ~out_enc ~entity_base:`Xml ())
110 let key_is_valid key =
111 if not (Str.string_match valid_key_rex key 0) then
112 raise (Malformed_key key)
114 let value_is_valid ~key ~value =
116 (fun (validator, descr) ->
117 if not (validator value) then
118 raise (Invalid_value ((key, value), descr)))
119 (Hashtbl.find_all validators key)
121 let set' registry ~key ~value =
122 debug_print (sprintf "Setting %s = %s" key value);
124 value_is_valid ~key ~value;
125 Hashtbl.replace registry key value
127 let unset = Hashtbl.remove registry
129 let env_var_of_key = Str.global_replace dot_rex "__"
132 let rec aux stack key =
134 if List.mem key stack then begin
135 let msg = (String.concat " -> " (List.rev stack)) ^ " -> " ^ key in
136 raise (Cyclic_definition msg)
138 let registry_value = (* internal value *)
140 Some (Hashtbl.find registry key)
141 with Not_found -> None
143 let env_value = (* environment value *)
145 Some (Sys.getenv (env_var_of_key key))
146 with Not_found -> None
148 let value = (* resulting value *)
149 match (registry_value, env_value) with
150 | Some reg, Some env -> env
151 | Some reg, None -> reg
152 | None, Some env -> env
153 | None, None -> raise (Key_not_found key)
155 interpolate (key :: stack) value
156 and interpolate stack value =
157 Str.global_substitute interpolated_key_rex
159 let matched = Str.matched_string s in
160 (* "$(var)" -> "var" *)
161 let key = String.sub matched 2 (String.length matched - 3) in
167 let set = set' registry
169 let has key = Hashtbl.mem registry key
171 let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) =
173 let value = get key in
177 raise (Type_error (type_name, value, Printexc.to_string exn))
179 let setter ~key ~value = set ~key ~value:(to_string value) in
182 let (get_string, set_string) = (get, set)
183 let (get_int, set_int) = mk_get_set "int" int_of_string string_of_int
184 let (get_float, set_float) = mk_get_set "float" float_of_string string_of_float
185 let (get_bool, set_bool) = mk_get_set "bool" bool_of_string string_of_bool
186 let (get_string_list, set_string_list) = mk_get_set "string list" split merge
188 let get_opt getter key =
191 with Key_not_found _ -> None
192 let set_opt setter ~key ~value =
195 | Some value -> setter ~key ~value
196 let get_opt_default getter default key =
197 match get_opt getter key with
201 let add_validator ~key ~validator ~descr =
202 let id = get_next_validator_id () in
203 Hashtbl.add validators key (validator, descr);
212 let dtd = new dtd PxpHelmConf.pxp_config.warner `Enc_utf8 in
213 let dot_RE = Str.regexp "\\." in
214 let create_key_node key value = (* create a <key name="foo">value</key> *)
216 create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd
219 let data = create_data_node PxpHelmConf.pxp_spec dtd value in
220 element#append_node data;
223 let is_section name =
225 match node#node_type with
226 | T_element "section" ->
227 (try node#attribute "name" = Value name with Not_found -> false)
230 let add_key_node root sections key value =
231 let rec aux node = function
233 let key_node = create_key_node key value in
234 node#append_node key_node
238 find ~deeply:false (is_section section) node
241 create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd
242 "section" ["name", section]
244 node#append_node section_node;
253 create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd
260 match List.rev (Str.split dot_RE key) with
266 add_key_node xml_root sections key value)
268 let outfile = open_out fname in
269 Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_LOCK 0; (* blocks *)
271 Unix.system "xmllint --version &> /dev/null" = Unix.WEXITED 0
273 let (xmllint_in, xmllint_out) =
274 Unix.open_process "xmllint --format --encode utf8 -"
276 xml_root#write (`Out_channel xmllint_out) `Enc_utf8;
277 close_out xmllint_out;
280 output_string outfile (input_line xmllint_in ^ "\n")
284 ignore (Unix.close_process (xmllint_in, xmllint_out))
286 xml_root#write (`Out_channel outfile) `Enc_utf8;
287 Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_ULOCK 0;
290 let load_from_absolute =
291 let config = PxpHelmConf.pxp_config in
292 let entry = `Entry_document [ `Extend_dtd_fully; `Parse_xml_decl ] in
293 let fold_key key_stack key =
296 | _ -> String.concat "." key_stack ^ "." ^ key
299 debug_print ("Loading configuration from " ^ fname);
301 parse_wfdocument_entity config (from_file fname) PxpHelmConf.pxp_spec
303 let rec aux key_stack node =
304 node#iter_nodes (fun n ->
306 (match n#node_type with
307 | T_element "section" ->
308 let section = n#required_string_attribute "name" in
309 aux (key_stack @ [section]) n
311 let key = n#required_string_attribute "name" in
312 let value = n#data in
313 set ~key:(fold_key key_stack key) ~value
316 let (fname, line, pos) = n#position in
317 raise (Parse_error (fname, line, pos,
318 "Uncaught exception: " ^ Printexc.to_string exn)))
320 let backup = backup_registry () in
321 Hashtbl.clear registry;
325 restore_registry backup;
328 let load_from ?path fname =
329 if Filename.is_relative fname then begin
330 let no_file_found = ref true in
333 | Some path -> path (* path given as argument *)
334 | None -> [ Sys.getcwd () ] (* no path given, try with cwd *)
338 let conffile = dir ^ "/" ^ fname in
339 if Sys.file_exists conffile then begin
340 no_file_found := false;
341 load_from_absolute conffile
344 if !no_file_found then
346 "Helm_registry.init: no configuration file named %s in [ %s ]"
347 fname (String.concat "; " path))
349 load_from_absolute fname
351 let fold ?prefix f init =
353 | None -> Hashtbl.fold (fun k v acc -> f acc k v) registry init
355 let key_matches = starts_with (s ^ ".") in
356 let rec fold_filter acc = function
358 | (k,v) :: tl when key_matches k -> fold_filter (f acc k v) tl
359 | _ :: tl -> fold_filter acc tl
361 fold_filter init (hashtbl_pairs registry)
363 let iter ?prefix f = fold ?prefix (fun _ k v -> f k v) ()
364 let to_list ?prefix () = fold ?prefix (fun acc k v -> (k, v) :: acc) []
367 let prefix = prefix ^ "." in
368 let prefix_len = String.length prefix in
369 let key_matches = starts_with prefix in
370 let matching_keys = (* collect matching keys' _postfixes_ *)
373 if key_matches key then
374 String.sub key prefix_len (String.length key - prefix_len) :: acc
379 let (sections, keys) =
381 (fun (sections, keys) postfix ->
382 match Str.split dot_rex postfix with
383 | [key] -> (sections, key :: keys)
384 | hd_key :: _ -> (* length > 1 => nested section found *)
385 (hd_key :: sections, keys)
387 ([], []) matching_keys
389 (list_uniq (List.sort Pervasives.compare sections), keys)
393 let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry