ocaml 3.09 transition

[helm.git] / helm / ocaml / registry / helm_registry.ml

diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml
index a845cb576e2017083a18230e66de0ce766295a93..35726d4c966868d20465c9374fb21bac1d1c8d29 100644 (file)
--- a/helm/ocaml/registry/helm_registry.ml
+++ b/helm/ocaml/registry/helm_registry.ml
@@ -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))
 
   (** <helpers> *)
 
@@ -117,10 +117,11 @@ let key_is_valid key =
   if not (Str.string_match valid_key_rex key 0) then
     raise (Malformed_key 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;
-  Hashtbl.add 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
 
@@ -163,8 +164,6 @@ let get registry key =
   in
   List.map strip_blanks (aux [] key)
 
-let set registry = set' registry
-
 let has registry key = Hashtbl.mem registry key
 
 let get_typed registry unmarshaller key =
@@ -172,7 +171,7 @@ let get_typed registry unmarshaller key =
   unmarshaller value
 
 let set_typed registry marshaller ~key ~value =
-  set registry ~key ~value:(marshaller value)
+  set' ~replace:true registry ~key ~value:(marshaller value)
 
 let get_opt registry unmarshaller key =
   try
@@ -187,7 +186,7 @@ let get_opt_default registry unmarshaller ~default key =
 let set_opt registry marshaller ~key ~value =
   match value with
   | None -> unset registry key
-  | Some value -> set registry ~key ~value:(marshaller value)
+  | Some value -> set' ~replace:true registry ~key ~value:(marshaller value)
 
 let get_list registry unmarshaller key =
   try
@@ -201,7 +200,10 @@ let get_pair registry fst_unmarshaller snd_unmarshaller key =
   | _ -> raise (Type_error "not a pair")
 
 let set_list registry marshaller ~key ~value =
-  List.iter (fun v -> set registry ~key ~value:(marshaller v)) value
+  Hashtbl.remove registry key;
+  List.iter
+    (fun v -> set' ~replace:false registry ~key ~value:(marshaller v))
+    value
 
 type xml_tree =
   | Cdata of string
@@ -242,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
@@ -262,17 +264,21 @@ let save_to registry fname =
   Xml.pp_to_outchan token_stream oc;
   close_out oc
 
-let load_from_absolute registry fname =
-  let path = ref [] in      (* <section> elements entered so far *)
+let rec load_from_absolute ?path registry fname =
+  let _path = ref (match path with None -> [] | Some p -> p)in
+    (* <section> elements entered so far *)
   let in_key = ref false in (* have we entered a <key> element? *)
   let cdata = ref "" in     (* collected cdata (inside <key> *)
-  let push_path name = path := name :: !path in
-  let pop_path () = path := List.tl !path in
+  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)))
@@ -281,12 +287,12 @@ let load_from_absolute registry fname =
     match tag with
     | "section" -> pop_path ()
     | "key" ->
-        let key = String.concat "." (List.rev !path) in
-        set registry ~key ~value:!cdata;
+        let key = String.concat "." (List.rev !_path) in
+        set' registry ~key ~value:!cdata;
         cdata := "";
         in_key := false;
         pop_path ()
-    | "helm_registry" -> ()
+    | "include" | "helm_registry" -> ()
     | _ -> assert false
   in
   let character_data text =
@@ -300,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 ->
@@ -383,7 +389,7 @@ let ls registry prefix =
 let default_registry = Hashtbl.create magic_size
 
 let get key = singleton (get default_registry key)
-let set = set default_registry
+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
@@ -401,6 +407,7 @@ let set_list marshaller = set_list default_registry marshaller
 let unset = unset default_registry
 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