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> *)
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
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 =
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
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
| _ -> 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
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)))
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 =
} 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 ->
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
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