helm/ocaml/registry/helm_registry.ml

   1 (* Copyright (C) 2004, HELM Team.
   2  *
   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.
   6  *
   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.
  11  *
  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.
  16  *
  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,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://helm.cs.unibo.it/
  24  *)
  25
  26 open Printf
  27
  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 *)
  33
  34 exception Unescape_failure
  35
  36 type validator_id = int
  37
  38 let get_next_validator_id =
  39   let next_id = ref 0 in
  40   fun () ->
  41     incr next_id;
  42     !next_id
  43
  44 let magic_size = 127
  45 let validators = Hashtbl.create magic_size
  46 let registry = Hashtbl.create magic_size
  47
  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
  52
  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 ^ "$")
  58
  59 let is_comment s = Pcre.pmatch ~rex:comment_rex s
  60
  61 let escape = String.escaped
  62 let unescape =
  63   let lexer = lazy (Genlex.make_lexer []) in
  64   fun s ->
  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
  69
  70 let key_is_valid key =
  71   if not (Pcre.pmatch ~rex:valid_key_rex key) then
  72     raise (Malformed_key key)
  73
  74 let value_is_valid ~key ~value =
  75   List.iter
  76     (fun (validator, descr) ->
  77       if not (validator value) then
  78         raise (Invalid_value ((key, value), descr)))
  79     (Hashtbl.find_all validators key)
  80
  81 let set' registry ~key ~value =
  82   key_is_valid key;
  83   value_is_valid ~key ~value;
  84   Hashtbl.replace registry key value
  85
  86 let get key =
  87   key_is_valid key;
  88   try
  89     Hashtbl.find registry key
  90   with Not_found -> raise (Key_not_found key)
  91
  92 let set = set' registry
  93
  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
  98
  99 let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) =
 100   let getter key =
 101     let value = get key in
 102     try
 103       from_string value
 104     with exn ->
 105       raise (Type_error (type_name, value, Printexc.to_string exn))
 106   in
 107   let setter ~key ~value = set ~key ~value:(to_string value) in
 108   (getter, setter)
 109
 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
 114
 115 let save_to fname =
 116   let oc = open_out fname in
 117   try
 118     Hashtbl.iter
 119       (fun key value ->
 120         output_string oc (sprintf "%s = \"%s\"" key (escape value)))
 121       registry;
 122     close_out oc
 123   with e ->
 124     close_out oc;
 125     raise e
 126
 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
 132   try
 133     while true do
 134       incr lineno;
 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
 139         set ~key ~value
 140     done
 141   with
 142   | End_of_file -> close_in ic
 143   | Malformed_key _ | Unescape_failure | Not_found ->
 144       restore_registry backup;
 145       raise (Parse_error (fname, !lineno))
 146   | e ->
 147       close_in ic;
 148       restore_registry backup;
 149       raise e
 150
 151 let add_validator ~key ~validator ~descr =
 152   let id = get_next_validator_id () in
 153   Hashtbl.add validators key (validator, descr);
 154   id
 155
 156 (*
 157   (* DEBUGGING *)
 158 let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry
 159 *)
 160