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 let debug = false
  29 let debug_print s =
  30   if debug then prerr_endline ("Helm_registry debugging: " ^ s)
  31
  32 exception Malformed_key of string
  33 exception Key_not_found of string
  34 exception Type_error of string * string * string (* expected type, value, msg *)
  35 exception Parse_error of string * int * int * string  (* file, line, col, msg *)
  36 exception Invalid_value of (string * string) * string (* key, value, descr *)
  37
  38 type validator_id = int
  39
  40 let get_next_validator_id =
  41   let next_id = ref 0 in
  42   fun () ->
  43     incr next_id;
  44     !next_id
  45
  46 let magic_size = 127
  47 let validators = Hashtbl.create magic_size
  48 let registry = Hashtbl.create magic_size
  49
  50 let backup_registry () = Hashtbl.copy registry
  51 let restore_registry backup =
  52   Hashtbl.clear registry;
  53   Hashtbl.iter (fun key value -> Hashtbl.replace registry key value) backup
  54
  55   (* as \\w but:
  56    * - no sequences of '_' longer than 1 are permitted
  57    * - no uppercase letter are permitted
  58    *)
  59 let valid_step_rex_raw = "[a-z0-9]+(_[a-z0-9]+)*"
  60 let valid_key_rex_raw =
  61   sprintf "%s(\\.%s)*" valid_step_rex_raw valid_step_rex_raw
  62 let valid_key_rex = Pcre.regexp ("^" ^ valid_key_rex_raw ^ "$")
  63
  64   (* escapes for xml configuration file *)
  65 let (escape, unescape) =
  66   let (in_enc, out_enc) = (`Enc_utf8, `Enc_utf8) in
  67   (Netencoding.Html.encode ~in_enc ~out_enc (),
  68    Netencoding.Html.decode ~in_enc ~out_enc ~entity_base:`Xml ())
  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   debug_print (sprintf "Setting %s = %s" key value);
  83   key_is_valid key;
  84   value_is_valid ~key ~value;
  85   Hashtbl.replace registry key value
  86
  87 let env_var_of_key =
  88   let dot_RE = Pcre.regexp "\\." in
  89   fun key ->
  90     Pcre.replace ~rex:dot_RE ~templ:"__" (String.uppercase key)
  91
  92 let get key =
  93   key_is_valid key;
  94   let registry_value =
  95     try
  96       Some (Hashtbl.find registry key)
  97     with Not_found -> None
  98   in
  99   let env_value =
 100     try
 101       Some (Sys.getenv (env_var_of_key key))
 102     with Not_found -> None
 103   in
 104   match (registry_value, env_value) with
 105   | Some reg, Some env  -> env
 106   | Some reg, None      -> reg
 107   | None,     Some env  -> env
 108   | None,     None      -> raise (Key_not_found key)
 109
 110 let set = set' registry
 111
 112 let string_list_of_string s =
 113   (* trailing blanks are removed per default by Pcre.split *)
 114   Pcre.split ~pat:"\\s+" (Pcre.replace ~pat:"^\\s+" s)
 115 let string_of_string_list l = String.concat " " l
 116
 117 let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) =
 118   let getter key =
 119     let value = get key in
 120     try
 121       from_string value
 122     with exn ->
 123       raise (Type_error (type_name, value, Printexc.to_string exn))
 124   in
 125   let setter ~key ~value = set ~key ~value:(to_string value) in
 126   (getter, setter)
 127
 128 let (get_string, set_string) = (get, set)
 129 let (get_int, set_int) = mk_get_set "int" int_of_string string_of_int
 130 let (get_float, set_float) = mk_get_set "float" float_of_string string_of_float
 131 let (get_string_list, set_string_list) =
 132   mk_get_set "string list" string_list_of_string string_of_string_list
 133
 134 let save_to fname =
 135   debug_print ("Saving configuration to " ^ fname);
 136   let oc = open_out fname in
 137   output_string oc "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n";
 138   output_string oc "<helm_registry>\n";
 139   try
 140     Hashtbl.iter
 141       (fun key value ->
 142         fprintf oc "  <value key=\"%s\">%s</value>\n" key (escape value))
 143       registry;
 144     output_string oc "</helm_registry>";
 145     close_out oc
 146   with e ->
 147     close_out oc;
 148     raise e
 149
 150 let add_validator ~key ~validator ~descr =
 151   let id = get_next_validator_id () in
 152   Hashtbl.add validators key (validator, descr);
 153   id
 154
 155 open Pxp_document
 156 open Pxp_types
 157 open Pxp_yacc
 158
 159 let load_from =
 160   let config = default_config in
 161   let entry = `Entry_document [ `Extend_dtd_fully; `Parse_xml_decl ] in
 162   fun fname ->
 163     debug_print ("Loading configuration from " ^ fname);
 164     let document =
 165       parse_wfdocument_entity config (from_file fname) default_spec
 166     in
 167     let fill_registry () =
 168       document#root#iter_nodes (fun n ->
 169         try
 170           (match n#node_type with
 171           | T_element "value" ->
 172               let key = n#required_string_attribute "key" in
 173               let value = n#data in
 174               set ~key ~value
 175           | _ -> ())
 176         with exn ->
 177           let (fname, line, pos) = n#position in
 178           raise (Parse_error (fname, line, pos,
 179             "Uncaught exception: " ^ Printexc.to_string exn)))
 180     in
 181     let backup = backup_registry () in
 182     Hashtbl.clear registry;
 183     try
 184       fill_registry ()
 185     with exn ->
 186       restore_registry backup;
 187       raise exn
 188
 189   (* DEBUGGING ONLY *)
 190
 191 let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry
 192