From fa5991432c5d63657964d2e91508df7ef74037d9 Mon Sep 17 00:00:00 2001
From: Stefano Zacchiroli <zack@upsilon.cc>
Date: Thu, 20 May 2004 12:07:37 +0000
Subject: [PATCH] - added "has" method - added "ls" method - added "?prefix"
 parameter to "fold", "iter" and "to_list" methods

---
 helm/ocaml/registry/helm_registry.ml  | 77 ++++++++++++++++++++++++---
 helm/ocaml/registry/helm_registry.mli | 11 ++--
 2 files changed, 79 insertions(+), 9 deletions(-)

diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml
index 2b6461b56..10639e089 100644
--- a/helm/ocaml/registry/helm_registry.ml
+++ b/helm/ocaml/registry/helm_registry.ml
@@ -29,6 +29,34 @@ let debug = false
 let debug_print s =
   if debug then prerr_endline ("Helm_registry debugging: " ^ s)
 
+  (** <helpers> *)
+
+let list_uniq l =
+  let rec aux last_element = function
+    | [] -> []
+    | hd :: tl ->
+        (match last_element with
+        | Some elt when elt = hd -> aux last_element tl
+        | _ -> hd :: aux (Some hd) tl)
+  in
+  aux None l
+
+let starts_with prefix =
+(*
+  let rex = Str.regexp (Str.quote prefix) in
+  fun s -> Str.string_match rex s 0
+*)
+  let prefix_len = String.length prefix in
+  fun s ->
+    try
+      String.sub s 0 prefix_len = prefix
+    with Invalid_argument _ -> false
+
+let hashtbl_keys tbl = Hashtbl.fold (fun k _ acc -> k :: acc) tbl []
+let hashtbl_pairs tbl = Hashtbl.fold (fun k v acc -> (k,v) :: acc) tbl []
+
+  (** </helpers> *)
+
 exception Malformed_key of string
 exception Key_not_found of string
 exception Cyclic_definition of string
@@ -81,7 +109,6 @@ let (escape, unescape) =
    Netencoding.Html.decode ~in_enc ~out_enc ~entity_base:`Xml ())
 
 let key_is_valid key =
-(*   if not (Pcre.pmatch ~rex:valid_key_rex key) then *)
   if not (Str.string_match valid_key_rex key 0) then
     raise (Malformed_key key)
 
@@ -101,7 +128,6 @@ let set' registry ~key ~value =
 let unset = Hashtbl.remove registry
 
 let env_var_of_key key =
-(*   Pcre.replace ~rex:dot_rex ~templ:"__" (String.uppercase key) *)
   Str.global_replace dot_rex "__" (String.uppercase key)
 
 let get key =
@@ -142,6 +168,8 @@ let get key =
 
 let set = set' registry
 
+let has key = Hashtbl.mem registry key
+
 let mk_get_set type_name (from_string: string -> 'a) (to_string: 'a -> string) =
   let getter key =
     let value = get key in
@@ -187,7 +215,8 @@ let save_to =
   let dot_RE = Str.regexp "\\." in
   let create_key_node key value = (* create a <key name="foo">value</key> *)
     let element =
-      create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd "key" ["name", key]
+      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;
@@ -310,9 +339,45 @@ let load_from ?path fname =
   end else
     load_from_absolute fname
 
-let fold f init = Hashtbl.fold (fun k v acc -> f acc k v) registry init
-let iter f = fold (fun _ k v -> f k v) ()
-let to_list () = fold (fun acc k v -> (k, v) :: acc) []
+let fold ?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 ?prefix f = fold ?prefix (fun _ k v -> f k v) ()
+let to_list ?prefix () = fold ?prefix (fun acc k v -> (k, v) :: acc) []
+
+let ls 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
+      (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)
 
   (* DEBUGGING ONLY *)
 
diff --git a/helm/ocaml/registry/helm_registry.mli b/helm/ocaml/registry/helm_registry.mli
index 62e85c5f1..7b7ef874f 100644
--- a/helm/ocaml/registry/helm_registry.mli
+++ b/helm/ocaml/registry/helm_registry.mli
@@ -103,14 +103,19 @@ exception Invalid_value of (string * string) * string
   (** lookup key in registry with environment variable override *)
 val get: string -> string
 val set: key:string -> value:string -> unit
+val has: string -> bool
 
   (** remove a key from the current environment, next get over this key will
    * raise Key_not_found until the key will be redefined *)
 val unset: string -> unit
 
-val fold: ('a -> string -> string -> 'a) -> 'a -> 'a
-val iter: (string -> string -> unit) -> unit
-val to_list: unit -> (string * string) list
+val fold: ?prefix:string -> ('a -> string -> string -> 'a) -> 'a -> 'a
+val iter: ?prefix:string -> (string -> string -> unit) -> unit
+val to_list: ?prefix:string -> unit -> (string * string) list
+
+  (** @param prefix key representing the section whose contents should be listed
+  * @return section list * key list *)
+val ls: string -> string list * string list
 
 (** {2 Typed interface}
  * Three basic types are supported: strings, int and strings list. Strings
-- 
2.39.2