X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Focaml%2Fregistry%2Fhelm_registry.ml;fp=helm%2Focaml%2Fregistry%2Fhelm_registry.ml;h=0000000000000000000000000000000000000000;hb=1696761e4b8576e8ed81caa905fd108717019226;hp=0c7b437238d1e57c23a9d5bcf73d83d6e4fde2b1;hpb=5325734bc2e4927ed7ec146e35a6f0f2b49f50c1;p=helm.git diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml deleted file mode 100644 index 0c7b43723..000000000 --- a/helm/ocaml/registry/helm_registry.ml +++ /dev/null @@ -1,316 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Printf - -let debug = false -let debug_print s = - if debug then prerr_endline ("Helm_registry debugging: " ^ s) - -exception Malformed_key of string -exception Key_not_found of string -exception Cyclic_definition of string -exception Type_error of string * string * string (* expected type, value, msg *) -exception Parse_error of string * int * int * string (* file, line, col, msg *) -exception Invalid_value of (string * string) * string (* key, value, descr *) - -type validator_id = int - - (* root XML tag: used by save_to, ignored by load_from *) -let root_tag = "helm_registry" - -let get_next_validator_id = - let next_id = ref 0 in - fun () -> - incr next_id; - !next_id - -let magic_size = 127 -let validators = Hashtbl.create magic_size -let registry = Hashtbl.create magic_size - -let backup_registry () = Hashtbl.copy registry -let restore_registry backup = - Hashtbl.clear registry; - Hashtbl.iter (fun key value -> Hashtbl.replace registry key value) backup - - (* as \\w but: - * - no sequences of '_' longer than 1 are permitted - * - no uppercase letter are permitted - *) -let valid_step_rex_raw = "[a-z0-9]+\\(_[a-z0-9]+\\)*" -let valid_key_rex_raw = - sprintf "%s\(\\.%s\)*" valid_step_rex_raw valid_step_rex_raw -let valid_key_rex = Str.regexp ("^" ^ valid_key_rex_raw ^ "$") -let interpolated_key_rex = Str.regexp ("\\$(" ^ valid_key_rex_raw ^ ")") -let dot_rex = Str.regexp "\\." -let spaces_rex = Str.regexp "[ \t\n\r]+" -let heading_spaces_rex = Str.regexp "^[ \t\n\r]+" - -let split s = - (* trailing blanks are removed per default by split *) - Str.split spaces_rex (Str.global_replace heading_spaces_rex "" s) -let merge l = String.concat " " l - - (* escapes for xml configuration file *) -let (escape, unescape) = - let (in_enc, out_enc) = (`Enc_utf8, `Enc_utf8) in - (Netencoding.Html.encode ~in_enc ~out_enc (), - Netencoding.Html.decode ~in_enc ~out_enc ~entity_base:`Xml ()) - -let key_is_valid key = -(* if not (Pcre.pmatch ~rex:valid_key_rex key) then *) - if not (Str.string_match valid_key_rex key 0) then - raise (Malformed_key key) - -let value_is_valid ~key ~value = - List.iter - (fun (validator, descr) -> - if not (validator value) then - raise (Invalid_value ((key, value), descr))) - (Hashtbl.find_all validators key) - -let set' registry ~key ~value = - debug_print (sprintf "Setting %s = %s" key value); - key_is_valid key; - value_is_valid ~key ~value; - Hashtbl.replace registry key value - -let unset = Hashtbl.remove registry - -let env_var_of_key key = -(* Pcre.replace ~rex:dot_rex ~templ:"__" (String.uppercase key) *) - Str.global_replace dot_rex "__" (String.uppercase key) - -let get key = - let rec aux stack key = - key_is_valid key; - if List.mem key stack then begin - let msg = (String.concat " -> " (List.rev stack)) ^ " -> " ^ key in - raise (Cyclic_definition msg) - end; - let registry_value = (* internal value *) - try - Some (Hashtbl.find registry key) - with Not_found -> None - in - let env_value = (* environment value *) - try - Some (Sys.getenv (env_var_of_key key)) - with Not_found -> None - in - let value = (* resulting value *) - match (registry_value, env_value) with - | Some reg, Some env -> env - | Some reg, None -> reg - | None, Some env -> env - | None, None -> raise (Key_not_found key) - in - interpolate (key :: stack) value - and interpolate stack value = - Str.global_substitute interpolated_key_rex - (fun s -> - let matched = Str.matched_string s in - (* "$(var)" -> "var" *) - let key = String.sub matched 2 (String.length matched - 3) in - aux stack key) - value - in - aux [] key - -let set = set' registry - -let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) = - let getter key = - let value = get key in - try - from_string value - with exn -> - raise (Type_error (type_name, value, Printexc.to_string exn)) - in - let setter ~key ~value = set ~key ~value:(to_string value) in - (getter, setter) - -let (get_string, set_string) = (get, set) -let (get_int, set_int) = mk_get_set "int" int_of_string string_of_int -let (get_float, set_float) = mk_get_set "float" float_of_string string_of_float -let (get_bool, set_bool) = mk_get_set "bool" bool_of_string string_of_bool -let (get_string_list, set_string_list) = mk_get_set "string list" split merge - -let get_opt getter key = - try - Some (getter key) - with Key_not_found _ -> None -let set_opt setter ~key ~value = - match value with - | None -> unset key - | Some value -> setter ~key ~value -let get_opt_default getter default key = - match get_opt getter key with - | None -> default - | Some v -> v - -let add_validator ~key ~validator ~descr = - let id = get_next_validator_id () in - Hashtbl.add validators key (validator, descr); - id - -open Pxp_dtd -open Pxp_document -open Pxp_types -open Pxp_yacc - -let save_to = - let dtd = new dtd PxpHelmConf.pxp_config.warner `Enc_utf8 in - let dot_RE = Str.regexp "\\." in - let create_key_node key value = (* create a value *) - let element = - create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd "key" ["name", key] - in - let data = create_data_node PxpHelmConf.pxp_spec dtd value in - element#append_node data; - element - in - let is_section name = - fun node -> - match node#node_type with - | T_element "section" -> - (try node#attribute "name" = Value name with Not_found -> false) - | _ -> false - in - let add_key_node root sections key value = - let rec aux node = function - | [] -> - let key_node = create_key_node key value in - node#append_node key_node - | section :: tl -> - let next_node = - try - find ~deeply:false (is_section section) node - with Not_found -> - let section_node = - create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd - "section" ["name", section] - in - node#append_node section_node; - section_node - in - aux next_node tl - in - aux root sections - in - fun fname -> - let xml_root = - create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd "helm_registry" [] - in - Hashtbl.iter - (fun key value -> - let sections, key = - let hd, tl = - match List.rev (Str.split dot_RE key) with - | hd :: tl -> hd, tl - | _ -> assert false - in - List.rev tl, hd - in - add_key_node xml_root sections key value) - registry; - let outchan = (* let's write xml output to fname *) - if Unix.system "xmllint --version &> /dev/null" = Unix.WEXITED 0 then - (* xmllint available, use it! *) - Unix.open_process_out (sprintf - "xmllint --format --encode utf8 -o '%s' -" fname) - else - (* xmllint not available, write pxp ugly output directly to fname *) - open_out fname - in - xml_root#write (`Out_channel outchan) `Enc_utf8; - close_out outchan - -let load_from_absolute = - let config = PxpHelmConf.pxp_config in - let entry = `Entry_document [ `Extend_dtd_fully; `Parse_xml_decl ] in - let fold_key key_stack key = - match key_stack with - | [] -> key - | _ -> String.concat "." key_stack ^ "." ^ key - in - fun fname -> - debug_print ("Loading configuration from " ^ fname); - let document = - parse_wfdocument_entity config (from_file fname) PxpHelmConf.pxp_spec - in - let rec aux key_stack node = - node#iter_nodes (fun n -> - try - (match n#node_type with - | T_element "section" -> - let section = n#required_string_attribute "name" in - aux (key_stack @ [section]) n - | T_element "key" -> - let key = n#required_string_attribute "name" in - let value = n#data in - set ~key:(fold_key key_stack key) ~value - | _ -> ()) - with exn -> - let (fname, line, pos) = n#position in - raise (Parse_error (fname, line, pos, - "Uncaught exception: " ^ Printexc.to_string exn))) - in - let backup = backup_registry () in - Hashtbl.clear registry; - try - aux [] document#root - with exn -> - restore_registry backup; - raise exn - -let load_from ?path fname = - if Filename.is_relative fname then begin - let no_file_found = ref true in - let path = - match path with - | Some path -> path (* path given as argument *) - | None -> [ Sys.getcwd () ] (* no path given, try with cwd *) - in - List.iter - (fun dir -> - let conffile = dir ^ "/" ^ fname in - if Sys.file_exists conffile then begin - no_file_found := false; - load_from_absolute conffile - end) - path; - if !no_file_found then - failwith (sprintf - "Helm_registry.init: no configuration file named %s in [ %s ]" - fname (String.concat "; " path)) - end else - load_from_absolute fname - - (* DEBUGGING ONLY *) - -let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry -