+ load_from_absolute registry fname
+
+let fold registry ?prefix f init =
+ match prefix with
+ | None -> Hashtbl.fold (fun k v acc -> f acc k v) registry init
+ | Some s ->
+ let key_matches = starts_with (s ^ ".") in
+ let rec fold_filter acc = function
+ | [] -> acc
+ | (k,v) :: tl when key_matches k -> fold_filter (f acc k v) tl
+ | _ :: tl -> fold_filter acc tl
+ in
+ fold_filter init (hashtbl_pairs registry)
+
+let iter registry ?prefix f = fold registry ?prefix (fun _ k v -> f k v) ()
+let to_list registry ?prefix () =
+ fold registry ?prefix (fun acc k v -> (k, v) :: acc) []
+
+let ls registry prefix =
+ let prefix = prefix ^ "." in
+ let prefix_len = String.length prefix in
+ let key_matches = starts_with prefix in
+ let matching_keys = (* collect matching keys' _postfixes_ *)
+ fold registry
+ (fun acc key _ ->
+ if key_matches key then
+ String.sub key prefix_len (String.length key - prefix_len) :: acc
+ else
+ acc)
+ []
+ in
+ let (sections, keys) =
+ List.fold_left
+ (fun (sections, keys) postfix ->
+ match Str.split dot_rex postfix with
+ | [key] -> (sections, key :: keys)
+ | hd_key :: _ -> (* length > 1 => nested section found *)
+ (hd_key :: sections, keys)
+ | _ -> assert false)
+ ([], []) matching_keys
+ 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 -> ('a -> string -> string -> 'a) -> 'a -> 'a
+ =
+ fold _registry
+ 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*)