From f277b17863953c96c944ca5101394b6a726abc8c Mon Sep 17 00:00:00 2001
From: Stefano Zacchiroli <zack@upsilon.cc>
Date: Mon, 24 May 2004 12:15:09 +0000
Subject: [PATCH] added OO interface

---
 helm/ocaml/registry/helm_registry.ml  | 168 ++++++++++++++++++++------
 helm/ocaml/registry/helm_registry.mli |  42 ++++++-
 2 files changed, 167 insertions(+), 43 deletions(-)

diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml
index ffe3b3a20..8e300797a 100644
--- a/helm/ocaml/registry/helm_registry.ml
+++ b/helm/ocaml/registry/helm_registry.ml
@@ -64,23 +64,25 @@ exception Type_error of string * string * 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
 
-  (* root XML tag: used by save_to, ignored by load_from *)
-let root_tag = "helm_registry"
-
 let get_next_validator_id =
   let next_id = ref 0 in
   fun () ->
     incr next_id;
     !next_id
 
-let magic_size = 127
 let validators = Hashtbl.create magic_size
-let registry = Hashtbl.create magic_size
+*)
+
+  (* root XML tag: used by save_to, ignored by load_from *)
+let root_tag = "helm_registry"
+
+let magic_size = 127
 
-let backup_registry () = Hashtbl.copy registry
-let restore_registry backup =
+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
 
@@ -111,24 +113,26 @@ 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;
+(*   value_is_valid ~key ~value; *)
   Hashtbl.replace registry key value
 
-let unset = Hashtbl.remove registry
+let unset registry = Hashtbl.remove registry
 
 let env_var_of_key = Str.global_replace dot_rex "__"
 
-let get key =
+let get registry key =
   let rec aux stack key =
     key_is_valid key;
     if List.mem key stack then begin
@@ -164,19 +168,23 @@ let get key =
   in
   aux [] key
 
-let set = set' registry
+let set registry = set' registry
 
-let has key = Hashtbl.mem registry key
+let has registry 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
+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 ~key ~value = set ~key ~value:(to_string value) in
+  let setter registry ~key ~value =
+    set registry ~key ~value:(to_string value)
+  in
   (getter, setter)
 
 let (get_string, set_string) = (get, set)
@@ -185,23 +193,25 @@ 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 get_opt getter key =
+let get_opt registry getter key =
   try
-    Some (getter key)
+    Some (getter registry key)
   with Key_not_found _ -> None
-let set_opt setter ~key ~value =
+let set_opt registry setter ~key ~value =
   match value with
-  | None -> unset key
-  | Some value -> setter ~key ~value
-let get_opt_default getter default key =
-  match get_opt getter key 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
   | 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
+*)
 
 open Pxp_dtd
 open Pxp_document
@@ -248,7 +258,7 @@ let save_to =
     in
     aux root sections
   in
-  fun fname ->
+  fun registry fname ->
     let xml_root =
       create_element_node ~valcheck:false PxpHelmConf.pxp_spec dtd
       "helm_registry" []
@@ -295,7 +305,7 @@ let load_from_absolute =
     | [] -> key
     | _ -> String.concat "." key_stack ^ "." ^ key
   in
-  fun fname ->
+  fun registry fname ->
     debug_print ("Loading configuration from " ^ fname);
     let document =
       parse_wfdocument_entity config (from_file fname) PxpHelmConf.pxp_spec
@@ -310,22 +320,22 @@ let load_from_absolute =
           | T_element "key" ->
               let key = n#required_string_attribute "name" in
               let value = n#data in
-              set ~key:(fold_key key_stack key) ~value
+              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 () in
+    let backup = backup_registry registry in
     Hashtbl.clear registry;
     try
       aux [] document#root
     with exn ->
-      restore_registry backup;
+      restore_registry backup registry;
       raise exn
 
-let load_from ?path fname =
+let load_from registry ?path fname =
   if Filename.is_relative fname then begin
     let no_file_found = ref true in
     let path =
@@ -338,7 +348,7 @@ let load_from ?path fname =
         let conffile = dir ^ "/" ^ fname in
         if Sys.file_exists conffile then begin
           no_file_found := false;
-          load_from_absolute conffile
+          load_from_absolute registry conffile
         end)
        path;
     if !no_file_found then
@@ -346,9 +356,9 @@ let load_from ?path fname =
         "Helm_registry.init: no configuration file named %s in [ %s ]"
         fname (String.concat "; " path))
   end else
-    load_from_absolute fname
+    load_from_absolute registry fname
 
-let fold ?prefix f init =
+let fold registry ?prefix f init =
   match prefix with
   | None -> Hashtbl.fold (fun k v acc -> f acc k v) registry init
   | Some s ->
@@ -360,15 +370,16 @@ let fold ?prefix f init =
       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 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 prefix =
+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
+    fold registry
       (fun acc key _ ->
         if key_matches key then
           String.sub key prefix_len (String.length key - prefix_len) :: acc
@@ -388,7 +399,86 @@ let ls prefix =
   in
   (list_uniq (List.sort Pervasives.compare sections), keys)
 
-  (* DEBUGGING ONLY *)
-
-let dump () = Hashtbl.iter (fun k v -> printf "%s = %s\n" k v) registry
+(** {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*)
+
+let default_registry = Hashtbl.create magic_size
+
+let get = get default_registry
+let set = set default_registry
+let has = has default_registry
+let fold ?prefix f init = fold default_registry ?prefix 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 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
 
diff --git a/helm/ocaml/registry/helm_registry.mli b/helm/ocaml/registry/helm_registry.mli
index 0f13a6162..a6b51271b 100644
--- a/helm/ocaml/registry/helm_registry.mli
+++ b/helm/ocaml/registry/helm_registry.mli
@@ -164,8 +164,9 @@ val get_opt_default:  (* as get_opt with an additional default value *)
  * associated to the corresponding key are executed, if at least one of them
  * fails, Invalid_value exception will be raised *)
 
-type validator_id
 
+(*
+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
@@ -176,7 +177,8 @@ type validator_id
 val add_validator:
   key:string -> validator:(string -> bool) -> descr:string ->
     validator_id
-(* val remove_validator: validator_id -> unit *)
+val remove_validator: validator_id -> unit
+*)
 
 (** {2 Persistent configuration}
  * Validators aren't saved. load_from/save_to sequences don't preserve comments
@@ -196,6 +198,38 @@ val save_to: string -> unit
    *)
 val load_from: ?path:string list -> string -> unit
 
-(* DEBUGGING *)
-(* val dump: unit -> 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 -> ('a -> string -> string -> 'a) -> 'a -> 'a
+    method iter: ?prefix:string -> (string -> string -> unit) -> unit
+    method to_list: ?prefix:string -> 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
 
-- 
2.39.2