X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fregistry%2Fhelm_registry.ml;h=35726d4c966868d20465c9374fb21bac1d1c8d29;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=8966bb9479b20f2b1dfe53013fb2da55b6499784;hpb=dfdf5642131761008f0b0430594a83d45ab62789;p=helm.git diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml index 8966bb947..35726d4c9 100644 --- a/helm/ocaml/registry/helm_registry.ml +++ b/helm/ocaml/registry/helm_registry.ml @@ -1,4 +1,4 @@ -(* Copyright (C) 2004, HELM Team. +(* Copyright (C) 2004-2005, HELM Team. * * This file is part of HELM, an Hypertextual, Electronic * Library of Mathematics, developed at the Computer Science @@ -27,7 +27,7 @@ open Printf let debug = false let debug_print s = - if debug then prerr_endline ("Helm_registry debugging: " ^ s) + if debug then prerr_endline ("Helm_registry debugging: " ^ (Lazy.force s)) (** *) @@ -60,21 +60,8 @@ let hashtbl_pairs tbl = Hashtbl.fold (fun k v acc -> (k,v) :: acc) tbl [] 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 Type_error of 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 - -let get_next_validator_id = - let next_id = ref 0 in - fun () -> - incr next_id; - !next_id - -let validators = Hashtbl.create magic_size -*) (* root XML tag: used by save_to, ignored by load_from *) let root_tag = "helm_registry" @@ -84,7 +71,7 @@ let magic_size = 127 let backup_registry registry = Hashtbl.copy registry let restore_registry backup registry = Hashtbl.clear registry; - Hashtbl.iter (fun key value -> Hashtbl.replace registry key value) backup + Hashtbl.iter (fun key value -> Hashtbl.add registry key value) backup (* as \\w but: * - no sequences of '_' longer than 1 are permitted @@ -107,6 +94,19 @@ let split s = Str.split spaces_rex (Str.global_replace heading_spaces_rex "" s) let merge l = String.concat " " l +let handle_type_error f x = + try f x with exn -> raise (Type_error (Printexc.to_string exn)) + + (** marshallers/unmarshallers *) +let string x = x +let int = handle_type_error int_of_string +let float = handle_type_error float_of_string +let bool = handle_type_error bool_of_string +let of_string x = x +let of_int = handle_type_error string_of_int +let of_float = handle_type_error string_of_float +let of_bool = handle_type_error string_of_bool + (* escapes for xml configuration file *) let (escape, unescape) = let (in_enc, out_enc) = (`Enc_utf8, `Enc_utf8) in @@ -117,25 +117,21 @@ let key_is_valid key = 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); +let set' ?(replace=false) registry ~key ~value = + debug_print (lazy(sprintf "Setting (replace: %b) %s = %s" replace key value)); key_is_valid key; -(* value_is_valid ~key ~value; *) - Hashtbl.replace registry key value + let add_fun = if replace then Hashtbl.replace else Hashtbl.add in + add_fun registry key value let unset registry = Hashtbl.remove registry let env_var_of_key = Str.global_replace dot_rex "__" +let singleton = function + | [] -> + raise (Type_error ("empty list value found where singleton was expected")) + | hd :: _ -> hd + let get registry key = let rec aux stack key = key_is_valid key; @@ -143,79 +139,71 @@ let get registry key = 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 + (* internal value *) + let registry_values = List.rev (Hashtbl.find_all registry key) 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) + let values = (* resulting value *) + match registry_values, env_value with + | _, Some env -> [env] + | [], None -> raise (Key_not_found key) + | values, None -> values in - interpolate (key :: stack) value + List.map (interpolate (key :: stack)) values 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) + singleton (aux stack key)) value in - strip_blanks (aux [] key) - -let set registry = set' registry + List.map strip_blanks (aux [] key) let has registry key = Hashtbl.mem registry key -let mk_get_set type_name - (from_string: string -> 'a) (to_string: 'a -> string) - = - let getter registry key = - let value = get registry key in - try - from_string value - with exn -> - raise (Type_error (type_name, value, Printexc.to_string exn)) - in - let setter registry ~key ~value = - set registry ~key ~value:(to_string value) - in - (getter, setter) +let get_typed registry unmarshaller key = + let value = singleton (get registry key) in + unmarshaller value -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 set_typed registry marshaller ~key ~value = + set' ~replace:true registry ~key ~value:(marshaller value) -let get_opt registry getter key = +let get_opt registry unmarshaller key = try - Some (getter registry key) + Some (unmarshaller (singleton (get registry key))) with Key_not_found _ -> None -let set_opt registry setter ~key ~value = - match value with - | None -> unset registry key - | Some value -> setter registry ~key ~value -let get_opt_default registry getter default key = - match get_opt registry getter key with + +let get_opt_default registry unmarshaller ~default key = + match get_opt registry unmarshaller 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 -*) +let set_opt registry marshaller ~key ~value = + match value with + | None -> unset registry key + | Some value -> set' ~replace:true registry ~key ~value:(marshaller value) + +let get_list registry unmarshaller key = + try + List.map unmarshaller (get registry key) + with Key_not_found _ -> [] + +let get_pair registry fst_unmarshaller snd_unmarshaller key = + let v = singleton (get registry key) in + match Str.split spaces_rex v with + | [fst; snd] -> fst_unmarshaller fst, snd_unmarshaller snd + | _ -> raise (Type_error "not a pair") + +let set_list registry marshaller ~key ~value = + Hashtbl.remove registry key; + List.iter + (fun v -> set' ~replace:false registry ~key ~value:(marshaller v)) + value type xml_tree = | Cdata of string @@ -256,9 +244,9 @@ let xml_tree_of_registry registry = | _ -> assert false in Hashtbl.fold - (fun k v tree -> add_key ("helm_registry" :: (Str.split dot_RE k)) v tree) + (fun k v tree -> add_key ((Str.split dot_RE k)) v tree) registry - (Element ("helm_registry", [], [])) + (Element (root_tag, [], [])) let rec stream_of_xml_tree = function | Cdata s -> Xml.xml_cdata s @@ -276,140 +264,21 @@ let save_to registry fname = Xml.pp_to_outchan token_stream oc; close_out oc -(* PXP version *) -(*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 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 registry 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 outfile = open_out fname in*) -(* Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_LOCK 0; |+ blocks +|*) -(* if*) -(* Unix.system "xmllint --version &> /dev/null" = Unix.WEXITED 0*) -(* then begin*) -(* let (xmllint_in, xmllint_out) =*) -(* Unix.open_process "xmllint --format --encode utf8 -"*) -(* in*) -(* xml_root#write (`Out_channel xmllint_out) `Enc_utf8;*) -(* close_out xmllint_out;*) -(* try*) -(* while true do*) -(* output_string outfile (input_line xmllint_in ^ "\n")*) -(* done*) -(* with End_of_file ->*) -(* close_in xmllint_in;*) -(* ignore (Unix.close_process (xmllint_in, xmllint_out))*) -(* end else*) -(* xml_root#write (`Out_channel outfile) `Enc_utf8;*) -(* Unix.lockf (Unix.descr_of_out_channel outfile) Unix.F_ULOCK 0;*) -(* close_out outfile*) - -(* PXP version *) -(*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 registry 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 registry ~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 registry in*) -(* Hashtbl.clear registry;*) -(* try*) -(* aux [] document#root*) -(* with exn ->*) -(* restore_registry backup registry;*) -(* raise exn*) - -(* XmlPushParser version *) -let load_from_absolute registry fname = - let path = ref [] in (*
elements entered so far *) +let rec load_from_absolute ?path registry fname = + let _path = ref (match path with None -> [] | Some p -> p)in + (*
elements entered so far *) let in_key = ref false in (* have we entered a element? *) - let push_path name = path := name :: !path in - let pop_path () = path := List.tl !path in + let cdata = ref "" in (* collected cdata (inside *) + let push_path name = _path := name :: !_path in + let pop_path () = _path := List.tl !_path in let start_element tag attrs = match tag, attrs with | "section", ["name", name] -> push_path name | "key", ["name", name] -> in_key := true; push_path name | "helm_registry", _ -> () + | "include", ["href", fname] -> + debug_print (lazy ("including file " ^ fname)); + load_from_absolute ~path:!_path registry fname | tag, _ -> raise (Parse_error (fname, ~-1, ~-1, (sprintf "unexpected element <%s> or wrong attribute set" tag))) @@ -417,20 +286,17 @@ let load_from_absolute registry fname = let end_element tag = match tag with | "section" -> pop_path () - | "key" -> in_key := false; pop_path () - | "helm_registry" -> () + | "key" -> + let key = String.concat "." (List.rev !_path) in + set' registry ~key ~value:!cdata; + cdata := ""; + in_key := false; + pop_path () + | "include" | "helm_registry" -> () | _ -> assert false in let character_data text = - if !in_key then - let key = String.concat "." (List.rev !path) in - let value = - if Hashtbl.mem registry key then - Hashtbl.find registry key ^ text - else - text - in - set registry ~key ~value + if !in_key then cdata := !cdata ^ text in let callbacks = { XmlPushParser.default_callbacks with @@ -440,7 +306,7 @@ let load_from_absolute registry fname = } in let xml_parser = XmlPushParser.create_parser callbacks in let backup = backup_registry registry in - Hashtbl.clear registry; +(* if path = None then Hashtbl.clear registry; *) try XmlPushParser.parse xml_parser (`File fname) with exn -> @@ -471,7 +337,9 @@ let load_from registry ?path fname = load_from_absolute registry fname let fold registry ?prefix ?(interpolate = true) f init = - let value_of k v = if interpolate then get registry k else strip_blanks v in + let value_of k v = + if interpolate then singleton (get registry k) else strip_blanks v + in match prefix with | None -> Hashtbl.fold (fun k v acc -> f acc k (value_of k v)) registry init | Some s -> @@ -514,90 +382,39 @@ let ls registry prefix = in (list_uniq (List.sort Pervasives.compare sections), keys) -(** {2 OO interface} *) - -class registry ?path fname = - object (self) - val _registry = Hashtbl.create magic_size - initializer load_from _registry ?path fname - method get = get _registry - method set = set _registry - method has = has _registry - method unset = unset _registry - method fold: - 'a. - ?prefix:string -> ?interpolate: bool -> - ('a -> string -> string -> 'a) -> 'a -> 'a - = - fun ?prefix ?interpolate f init -> - fold _registry ?prefix ?interpolate f init - method iter = iter _registry - method to_list = to_list _registry - method ls = ls _registry - method get_string = get_string _registry - method get_int = get_int _registry - method get_float = get_float _registry - method get_bool = get_bool _registry - method get_string_list = get_string_list _registry - method set_string = set_string _registry - method set_int = set_int _registry - method set_float = set_float _registry - method set_bool = set_bool _registry - method set_string_list = set_string_list _registry - method get_opt: 'a. (string -> 'a) -> string -> 'a option = - fun getter key -> - try Some (getter key) with Key_not_found _ -> None - method set_opt: - 'a. (key:string -> value:'a -> unit) -> key:string -> value:'a option -> - unit - = - fun setter ~key ~value -> - match value with - | None -> self#unset key - | Some value -> setter ~key ~value - method get_opt_default: 'a. (string -> 'a) -> 'a -> string -> 'a = - fun getter default key -> - match self#get_opt getter key with - | None -> default - | Some v -> v - method save_to = save_to _registry -(* method load_from = load_from _registry *) - end - (** {2 API implementation} * functional methods above are wrapped so that they work on a default * (imperative) registry*) let default_registry = Hashtbl.create magic_size -let get = get default_registry -let set = set default_registry +let get key = singleton (get default_registry key) +let set = set' ~replace:true default_registry let has = has default_registry let fold ?prefix ?interpolate f init = fold default_registry ?prefix ?interpolate f init let iter = iter default_registry let to_list = to_list default_registry let ls = ls default_registry -let get_string = get_string default_registry -let get_int = get_int default_registry -let get_float = get_float default_registry -let get_bool = get_bool default_registry -let get_string_list = get_string_list default_registry -let set_string = set_string default_registry -let set_int = set_int default_registry -let set_float = set_float default_registry -let set_bool = set_bool default_registry -let set_string_list = set_string_list default_registry -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 default_registry key - | Some value -> setter ~key ~value +let get_typed unmarshaller = get_typed default_registry unmarshaller +let get_opt unmarshaller = get_opt default_registry unmarshaller +let get_opt_default unmarshaller = get_opt_default default_registry unmarshaller +let get_list unmarshaller = get_list default_registry unmarshaller +let get_pair unmarshaller = get_pair default_registry unmarshaller +let set_typed marshaller = set_typed default_registry marshaller +let set_opt unmarshaller = set_opt default_registry unmarshaller +let set_list marshaller = set_list default_registry marshaller let unset = unset default_registry -let get_opt_default getter default key = - match get_opt getter key with - | None -> default - | Some v -> v let save_to = save_to default_registry let load_from = load_from default_registry +let clear () = Hashtbl.clear default_registry + +let get_string = get_typed string +let get_int = get_typed int +let get_float = get_typed float +let get_bool = get_typed bool +let set_string = set_typed of_string +let set_int = set_typed of_int +let set_float = set_typed of_float +let set_bool = set_typed of_bool