From 1bb2cfafdfd2a3648ca8d2eac8b1952210fc5e65 Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Wed, 15 Jun 2005 11:31:15 +0000 Subject: [PATCH] - support for multiple bindings of the same key, accessible via get_list - changed get_opt interface so that marshallers/unmarshallers are needed instead of getters/setters --- helm/ocaml/registry/helm_registry.ml | 362 ++++++-------------------- helm/ocaml/registry/helm_registry.mli | 164 ++++-------- helm/ocaml/registry/tests/sample.xml | 10 + 3 files changed, 149 insertions(+), 387 deletions(-) diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml index 8966bb947..501f689d8 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 @@ -60,22 +60,10 @@ 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 +72,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 +95,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 +118,20 @@ 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); key_is_valid key; -(* value_is_valid ~key ~value; *) - Hashtbl.replace registry key value + Hashtbl.add 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,64 @@ 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) + List.map strip_blanks (aux [] key) let set registry = set' registry 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 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 registry ~key ~value:(marshaller value) + +let get_list registry unmarshaller key = + try + List.map unmarshaller (get registry key) + with Key_not_found _ -> [] + +let set_list registry marshaller ~key ~value = + List.iter (fun v -> set registry ~key ~value:(marshaller v)) value type xml_tree = | Cdata of string @@ -276,133 +257,10 @@ 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 path = ref [] in (*
elements entered so far *) let in_key = ref false in (* have we entered a element? *) + 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 = @@ -417,20 +275,17 @@ let load_from_absolute registry fname = let end_element tag = match tag with | "section" -> pop_path () - | "key" -> in_key := false; pop_path () + | "key" -> + let key = String.concat "." (List.rev !path) in + set registry ~key ~value:!cdata; + cdata := ""; + in_key := false; + pop_path () | "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 @@ -471,7 +326,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,63 +371,13 @@ 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 get key = singleton (get default_registry key) let set = set default_registry let has = has default_registry let fold ?prefix ?interpolate f init = @@ -578,26 +385,23 @@ let fold ?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 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 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 + diff --git a/helm/ocaml/registry/helm_registry.mli b/helm/ocaml/registry/helm_registry.mli index e108ff01d..e9ee901e8 100644 --- a/helm/ocaml/registry/helm_registry.mli +++ b/helm/ocaml/registry/helm_registry.mli @@ -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 @@ -72,11 +72,9 @@ exception Key_not_found of string * @param msg brief description of the definition cycle *) exception Cyclic_definition of string - (** raised when a looked up key doesn't have the required type - * @param expected_type - * @param value - * @param msg *) -exception Type_error of string * string * string + (** raised when a looked up key doesn't have the required type, parameter is + * an error message *) +exception Type_error of string (** raised when a malformed key is encountered * @param key malformed key *) @@ -133,71 +131,60 @@ val ls: string -> string list * string list * parsing of an integer number from ; strings list to the splitting at blanks * of it (heading and trailing blanks are removed before splitting) *) -val get_string: string -> string (* alias for bare "get" above *) -val get_int: string -> int -val get_float: string -> float -val get_bool: string -> bool -val get_string_list: string -> string list - - (* alias for bare "set" above *) -val set_string: key:string -> value:string -> unit -val set_int: key:string -> value:int -> unit -val set_float: key:string -> value:float -> unit -val set_bool: key:string -> value:bool -> unit -val set_string_list: key:string -> value:string list -> unit - -(** {3 Optional values interface} - * Functions below took as first argument respectively a "getter" and a "setter" - * function. A getter is one of the get_* function above, a setter is one of the - * set_* function above. Returned value is a get (set) function typed as the - * given getter (setter) whith optional values. None is returned for missing - * keys and None can be assigned to a key removing it from the registry. - * - * Sample usage: - * - * match Helm_registry.get_opt Helm_registry.get_int "foo.bar" with - * | Some i -> ... - * | None -> ... - *) +(** {3 Unmarshallers} *) -val get_opt: - (string -> 'a) (* getter *) -> - string -> 'a option -val set_opt: - (key:string -> value:'a -> unit) (* setter *) -> - key:string -> value:'a option -> unit -val get_opt_default: (* as get_opt with an additional default value *) - (string -> 'a) -> 'a -> string -> 'a - -(** {2 Validators} - * Each key may have zero or more associated validators, that are predicates - * "this value is valid for this key". Each time a value is set, all validators - * associated to the corresponding key are executed, if at least one of them - * fails, Invalid_value exception will be raised *) - - -(* -type validator_id - (** register a new validator for a given key - * @param key key to which validator applies - * @param validator a function applying to a value returning true if that - * value is valid, false otherwise - * @param descr validator description, for the final user when a validation - * attempt fails - * @return validator_id should be used to remove the validator later on *) -val add_validator: - key:string -> validator:(string -> bool) -> descr:string -> - validator_id -val remove_validator: validator_id -> unit -*) - -(** {2 Persistent configuration} - * Validators aren't saved. load_from/save_to sequences don't preserve comments - *) +val string: string -> string +val int: string -> int +val float: string -> float +val bool: string -> bool + +(** {3 Typed getters} *) + + (** like get, with an additional unmarshaller + * @param unmarshaller conversion function from string to the desired type. + * Use one of the above unmarshallers *) +val get_typed: (string -> 'a) -> string -> 'a + +val get_opt: (string -> 'a) -> string -> 'a option +val get_opt_default: (string -> 'a) -> default:'a -> string -> 'a + + (** never fails with Key_not_found, instead return the empty list *) +val get_list: (string -> 'a) -> string -> 'a list + +(** {4 Shorthands} *) + +val get_string: string -> string +val get_int: string -> int +val get_float: string -> float +val get_bool: string -> bool - (** @param fname file to which save current configuration - * If xmllint is available then it will be used for pretty printing fname, - * otherwise fname will be in the usual pxp ugly format *) +(** {3 Marshallers} *) + +val of_string: string -> string +val of_int: int -> string +val of_float: float -> string +val of_bool: bool -> string + +(** {3 Typed setters} *) + + (** like set, with an additional marshaller + * @param marshaller conversion function to string. + * Use one of the above marshallers *) +val set_typed: ('a -> string) -> key:string -> value:'a -> unit + +val set_opt: ('a -> string) -> key:string -> value:'a option -> unit +val set_list: ('a -> string) -> key:string -> value:'a list -> unit + +(** {4 Shorthands} *) + +val set_string: key:string -> value:string -> unit +val set_int: key:string -> value:int -> unit +val set_float: key:string -> value:float -> unit +val set_bool: key:string -> value:bool -> unit + +(** {2 Persistent configuration} *) + + (** @param fname file to which save current configuration *) val save_to: string -> unit (** @param fname file from which load new configuration. If it's an absolute @@ -209,42 +196,3 @@ val save_to: string -> unit *) val load_from: ?path:string list -> string -> unit -(** {2 OO interface} *) - - (** @see load_from *) -class registry: ?path: string list -> string -> - object - method get: string -> string - method set: key:string -> value:string -> unit - method has: string -> bool - method unset: string -> unit - method fold: - ?prefix:string -> ?interpolate:bool -> - ('a -> string -> string -> 'a) -> 'a -> 'a - method iter: - ?prefix:string -> ?interpolate:bool -> (string -> string -> unit) -> unit - method to_list: - ?prefix:string -> ?interpolate:bool -> unit -> (string * string) list - method ls: string -> string list * string list - method get_string: string -> string - method get_int: string -> int - method get_float: string -> float - method get_bool: string -> bool - method get_string_list: string -> string list - method set_string: key:string -> value:string -> unit - method set_int: key:string -> value:int -> unit - method set_float: key:string -> value:float -> unit - method set_bool: key:string -> value:bool -> unit - method set_string_list: key:string -> value:string list -> unit - method get_opt: - (string -> 'a) (* getter *) -> - string -> 'a option - method set_opt: - (key:string -> value:'a -> unit) (* setter *) -> - key:string -> value:'a option -> unit - method get_opt_default: - (string -> 'a) (* getter *) -> - 'a -> string -> 'a - method save_to: string -> unit - end - diff --git a/helm/ocaml/registry/tests/sample.xml b/helm/ocaml/registry/tests/sample.xml index e41a603e7..e8ebdc76b 100644 --- a/helm/ocaml/registry/tests/sample.xml +++ b/helm/ocaml/registry/tests/sample.xml @@ -8,6 +8,16 @@ remote http://localhost:58081
+
+ debian + 1 + false + 2.5 + 11 + 13 + 17 + 19 +
aaa -- 2.39.2