[fix] database: Fixed some problems with OPA and db_light.

database/badop_light.ml

@@ -45,12 +45,14 @@ let status db k = Badop.Light db.file |> k
 
 module Tr = struct
   let start db k =
+    (*Logger.debug "Badop_light.Tr.start";*)
     { db = db; tr = Session_light.new_trans db.session } |> k
 
   let start_at_revision db _rev k =
     { db = db; tr = Session_light.new_trans (*~read_only:(true, Some rev)*) db.session } |> k
 
   let prepare trans k =
+    (*Logger.debug "Badop_light.Tr.prepare";*)
     (* Executes [k] as soon as prepare finished, asynchronously, nonblocking.
        When prepare is postponed and stored on the FIFO,
        the continuation is stored as well. The exceptions from [k]
@@ -63,6 +65,7 @@ module Tr = struct
       ({db = trans.db; tr = trans.tr}, true) |> k
 
   let commit trans k =
+    (*Logger.debug "Badop_light.Tr.commit";*)
     if Transaction_light.modified trans.tr then
       (* Assumption: [trans] is prepared by [execute_trans_prepare].
          Here some continuations of [prepare] may be executed, but only in case
@@ -80,7 +83,9 @@ type revision = Revision.t
 (** All the operations that query the db *)
 type 'which read_op = ('which,revision) Badop.generic_read_op
 
-let read trans path op k = match op with
+let read trans path op k =
+  (*Logger.debug "Badop_light.read";*)
+  match op with
   | Badop.Stat (D.Query () as q) ->
       (try `Answer (Badop.Stat (D.Dialog_aux.respond q (Session_light.stat trans.tr path)))
        with Db_light.UnqualifiedPath -> `Absent) |> k
@@ -116,7 +121,9 @@ let read trans path op k = match op with
 (** All the operations that write to the db *)
 type 'which write_op = ('which,transaction,revision) Badop.generic_write_op
 
-let write trans path op k = match op with
+let write trans path op k =
+  (*Logger.debug "Badop_light.write";*)
+  match op with
   | Badop.Set (D.Query data as q) ->
       Badop.Set (D.Dialog_aux.respond q { trans with tr = Session_light.set trans.tr path data }) |> k
   | Badop.Clear (D.Query () as q) ->

database/db3/path.ml

@@ -87,6 +87,14 @@ module List = BaseList
     | x when x < 0 -> aux p1 p2
     | _ -> aux p2 p1
 
+  let is_prefix p1 p2 =
+    let rec aux = function
+      | (k1::r1,k2::r2) -> if Keys.equal k1 k2 then aux (r1,r2) else false
+      | ([],_) -> true
+      | _ -> false
+    in
+    aux (List.rev p1, List.rev p2)
+
   let concat p1 p2 = List.append p2 p1
 
   let to_list p = List.rev p

database/db3/path.mli

@@ -34,6 +34,7 @@
   val compare : t -> t -> int
   val remaining : t -> t -> Keys.t list option
   val remaining_prefix : t -> t -> t option
+  val is_prefix : t -> t -> bool
   val concat : t -> t -> t
   val to_list : t -> Keys.t list
   val of_list : Keys.t list -> t

database/light/db_light.ml

@@ -100,15 +100,15 @@ let sts_of_list l =
 let set_version t version = t.version <- version
 
 let update_data tree data =
-  let old_data = tree.node.Node_light.content in
+  let _old_data = tree.node.Node_light.content in
   (match tree.node.Node_light.content, data with
    | Datas.UnsetData, Datas.UnsetData -> ()
    | _, Datas.UnsetData -> ()
    | Datas.UnsetData, _ -> tree.node.Node_light.content <- data
    | _, _ -> tree.node.Node_light.content <- data);
   #<If$minlevel 3>Logger.log ~color:`cyan "update_data: data=%s old_data=%s new_data=%s"
                                                   (Datas.to_string data)
-                                                  (Datas.to_string old_data)
+                                                  (Datas.to_string _old_data)
                                                   (Datas.to_string tree.node.Node_light.content)#<End>
 
 let add_tree t path data =
@@ -136,16 +136,10 @@ let remove_tree t path =
     | [] -> false
     | [k] ->
         (try
-           let st = Hashtbl.find tree.sts k in
-           if Hashtbl.length st.sts = 0
-           then (#<If$minlevel 2>
-                 Logger.log ~color:`cyan "remove_tree(rmv): path=%s data=%s"
-                   (Path.to_string path) (Datas.to_string st.node.Node_light.content)#<End>;
-                 Hashtbl.remove tree.sts k)
-           else (#<If$minlevel 2>
-                 Logger.log ~color:`cyan "remove_tree(set): path=%s data=%s"
-                   (Path.to_string path) (Datas.to_string st.node.Node_light.content)#<End>;
-                 st.node.Node_light.content <- Datas.UnsetData);
+           let _st = Hashtbl.find tree.sts k in
+           #<If$minlevel 2>Logger.log ~color:`cyan "remove_tree(rmv): path=%s data=%s"
+                                                   (Path.to_string path) (Datas.to_string _st.node.Node_light.content)#<End>;
+           Hashtbl.remove tree.sts k;
            true
          with Not_found -> false)
     | k::rest ->
@@ -163,7 +157,7 @@ let remove_tree t path =
   removed
 
 (* Node-level navigation:
-   Note that we can't export this yet because the Badop.S sig doesn't support this.
+   Note that we can't export this yet because the Badop.S sig doesn't support it.
 *)
 
 exception At_root
@@ -350,14 +344,37 @@ let start = root_eid
     in
     aux tree path 0 ([],0) 0
 
-  (* may raise UnqualifiedPath *)
-  let rec get_children db range_opt path =
-    let tree = get_tree_of_path db path in
-    match Node_light.get_content tree.node with
-    | Datas.Link p
-    | Datas.Copy (_, p) -> get_children db range_opt p
-    | _ -> fst (get_ch db tree range_opt path 1 true)
+  let rec _get_children db range_opt path max_depth allow_empty raise_on_unqualified =
+    let tree =
+      if raise_on_unqualified
+      then
+        Some (get_tree_of_path db path)
+      else
+        try
+          Some (get_tree_of_path db path)
+        with UnqualifiedPath -> None
+    in
+    match tree with
+    | Some tree ->
+        (match Node_light.get_content tree.node with
+         | Datas.Link p
+         | Datas.Copy (_, p) -> _get_children db range_opt p max_depth allow_empty raise_on_unqualified
+         | _ -> fst (get_ch db tree range_opt path max_depth allow_empty))
+    | None -> []
 
+  (* may raise UnqualifiedPath *)
+  let get_children db range_opt path =
+    let ch = _get_children db range_opt path 1 true true in
+    #<If:DEBUG_DB$minlevel 20>Logger.info "Db_light.get_children: %s -> [%s]%!"
+      (Path.to_string path) (String.concat_map "; " Path.to_string ch)#<End>;
+    ch
+
+  (* won't raise UnqualifiedPath *)
+  let get_all_children db range_opt path =
+    let ch = _get_children db range_opt path max_int false false in
+    #<If:DEBUG_DB$minlevel 20>Logger.info "Db_light.get_all_children: %s -> [%s]%!"
+      (Path.to_string path) (String.concat_map "; " Path.to_string ch)#<End>;
+    ch
 
   (********************)
   (* basics DB writes *)

database/light/db_light.mli

@@ -20,6 +20,7 @@ exception Merge
 
 type t
 type tree
+
 (*type node_map*)
 type index = ((Path.t * float) list) StringMap.t
 
@@ -40,55 +41,28 @@ val get_rev : t -> Revision.t
 val get_tcount : t -> Eid.t
 val get_next_uid : t -> Uid.t
 val is_empty : t -> bool
-(*val get_uid_map : t -> Uid.t RevisionMap.t EidMap.t
-val get_node_map : t -> node_map
-val get_noweak_node_map : t -> Node.t UidMap.t
-val get_last_nodes : t -> Node.t UidMap.t*)
 val get_index : t -> index
 
 val set_version : t -> string -> unit
 
 (* navigation through the db *)
-(*val get_uid_of_eid : t -> Revision.t -> Eid.t -> Uid.t
-val get_node_of_uid : t -> Uid.t -> Node_light.t*)
 val get_node_of_path : t -> (*Revision.t ->*) Path.t -> Node_light.t * Revision.t
-(*val get_node_of_eid : t -> Revision.t -> Eid.t -> Node_light.t
-val get_eid_of_path : t -> Revision.t -> Path.t -> Eid.t * Revision.t
-val is_new_uid : t -> Uid.t -> bool*)
 val get_tree_of_path : t -> Path.t -> tree
 
-(* cleaning *)
-(*val clean_tmp_maps : t -> t*)
-
 (* creation / rebuilding of a database *)
-(*val make_node_map_from_weak : (Uid.t, Node_light.t) WeakCacheMap.t -> node_map
-val make_node_map_from_uidmap : Node_light.t UidMap.t -> node_map*)
-val make : (*?weak:(Uid.t -> Node_light.t) ->*) unit -> t
-(*val restart :
-  ?index:index ->
-  Revision.t -> Eid.t -> Uid.t ->
-  (Uid.t RevisionMap.t EidMap.t) ->
-  node_map ->
-  t*)
+val make : unit -> t
 
 (* basic db writing *)
-(*val update_db : t -> Revision.t -> (Eid.t * Uid.t) list -> (Uid.t * Node_light.t) list -> t*)
 val update : t -> Path.t -> Datas.t -> t
 val remove : t -> Path.t -> t
 val set_rev : t -> Revision.t -> t
 
 (* basic db reading *)
-val get : t -> (*Revision.t ->*) Path.t -> DataImpl.t
+val get : t -> Path.t -> DataImpl.t
 val get_data : t -> Node_light.t -> DataImpl.t
-(*val get_children :
-  t -> Revision.t -> (Keys.t option * int) option
-  -> Path.t -> (Path.t * Revision.t) list
-*)
 val get_children : t -> (Keys.t option * int) option -> Path.t -> Path.t list
-(*
-val get_descendants : t -> Path.t -> (Path.t * DataImpl.t) list
-val get_all_rev_of_path : t -> Path.t -> Revision.t list
-val get_last_rev_of_path : t -> Revision.t -> Path.t -> Revision.t*)
+val get_all_children : t -> (Keys.t option * int) option -> Path.t -> Path.t list
+
 (* Index management *)
 val update_index : t -> (Path.t * DataImpl.t) list -> t
 val remove_from_index : t -> (Path.t * DataImpl.t) list -> t
@@ -111,11 +85,8 @@ val set_copy : t -> Path.t -> Path.t -> t
     @return The node at which a copy or link was encountered
     and the remaining suffix of the path.
 *)
-val follow_path :
-  (*t -> Revision.t -> Node_light.t -> Keys.t list -> Keys.t list * Node_light.t*)
-  t -> tree -> Keys.t list -> Keys.t list * tree
+val follow_path : t -> tree -> Keys.t list -> Keys.t list * tree
 
-(*
 (** [follow_link db original_rev path] returns unwound path as it was
     at db revision [original_rev]. The result is independent on any
     changes to the databse after [original_rev]. There is no escape
@@ -129,7 +100,4 @@ val follow_path :
 
     @return The path unwound at [original_rev].
 *)
-val follow_link : t -> Revision.t -> Path.t -> Path.t * Node_light.t
-*)
-
 val follow_link : t -> Path.t -> Path.t * tree

database/light/io_light.ml

@@ -64,9 +64,9 @@ let really_remove_lock_file t =
                  | None -> ());
                 t.has_lock <- false;
                 Unix.unlink lock_file_name)
-        with exn ->
+        with _exn ->
           #<If>Logger.log ~color:`red "DB-LIGHT : Warning exception removing lock file: %s"
-                                              (Printexc.to_string exn)#<End>)
+                                              (Printexc.to_string _exn)#<End>)
   else ()
 
 let close t =
@@ -102,8 +102,8 @@ let make_lock_file t =
                Dbm.replace dbm "lock_hostname" hostname
            | None -> ());
           t.has_lock <- true
-        with exn ->
-          critical_error t (sprintf "DB-LIGHT : Can't create lock file %s" (Printexc.to_string exn)))
+        with _exn ->
+          critical_error t (sprintf "DB-LIGHT : Can't create lock file %s" (Printexc.to_string _exn)))
 
 let remove_lock_file t =
   let lock_file_name = t.location^"_lock" in
@@ -119,8 +119,8 @@ let remove_lock_file t =
                 with Dbm.Dbm_error "dbm_delete" -> ()));
           Unix.unlink lock_file_name;
           t.has_lock <- false
-        with exn ->
-          critical_error t (sprintf "DB-LIGHT : Can't remove lock file %s" (Printexc.to_string exn)))
+        with _exn ->
+          critical_error t (sprintf "DB-LIGHT : Can't remove lock file %s" (Printexc.to_string _exn)))
   else ()
 
 let read_lock_file t =
@@ -131,9 +131,9 @@ let read_lock_file t =
           let (pid,hostname) = Scanf.fscanf ic "%d\n%s\n" (fun i s -> (i,s)) in
           close_in ic;
           Some (hostname,pid)
-        with exn ->
+        with _exn ->
           (#<If>Logger.log ~color:`red "DB-LIGHT : Warning exception reading lock file: %s"
-                                               (Printexc.to_string exn)#<End>;
+                                               (Printexc.to_string _exn)#<End>;
            None))
   else None
 
@@ -183,8 +183,8 @@ let reopen t =
                t.dbm <- Some (Dbm.opendbm t.location (match t.mode with
                                                       | ReadOnly -> [Dbm.Dbm_rdonly;Dbm.Dbm_create]
                                                       | _ -> [Dbm.Dbm_rdwr;Dbm.Dbm_create]) File.default_rights))
-       with exn ->
-         failwith (sprintf "Can't reopen Dbm file %s %s" t.location (Printexc.to_string exn)))
+       with _exn ->
+         failwith (sprintf "Can't reopen Dbm file %s %s" t.location (Printexc.to_string _exn)))
 
 let make mode file =
   let cfile = File.explicit_path file (Some (Unix.getcwd())) in
@@ -206,11 +206,11 @@ let make mode file =
                if Sys.file_exists dir_file
                then (#<If>Logger.log ~color:`yellow "New db, purge: deleting file %s" dir_file#<End>;
                      (try Sys.remove dir_file
-                      with exn -> #<If>Logger.log ~color:`yellow "Error deleting file %s %s"
-                                                                    dir_file (Printexc.to_string exn)#<End>; ());
+                      with _exn -> #<If>Logger.log ~color:`yellow "Error deleting file %s %s"
+                                                                    dir_file (Printexc.to_string _exn)#<End>; ());
                      (try Sys.remove pag_file
-                      with exn -> #<If>Logger.log ~color:`yellow "Error deleting file %s %s"
-                                                                    pag_file (Printexc.to_string exn) #<End>; ()));
+                      with _exn -> #<If>Logger.log ~color:`yellow "Error deleting file %s %s"
+                                                                    pag_file (Printexc.to_string _exn) #<End>; ()));
                #<If>Logger.log ~color:`magenta "Opened new Dbm file %s" dir_file#<End>;
                let dbm = Dbm.opendbm cfile [Dbm.Dbm_rdwr;Dbm.Dbm_create] File.default_rights in
                Dbm.add dbm "version" version;
@@ -222,8 +222,8 @@ let make mode file =
            | ReadOnly ->
                #<If>Logger.log ~color:`magenta "Opened Dbm file for Read %s" dir_file#<End>;
                Dbm.opendbm file [Dbm.Dbm_rdonly] File.default_rights)
-        with exn ->
-          failwith (sprintf "Can't open Dbm file %s %s" file (Printexc.to_string exn))
+        with _exn ->
+          failwith (sprintf "Can't open Dbm file %s %s" file (Printexc.to_string _exn))
       in
       t.dbm <- Some dbm;
       t.link_count <- t.link_count + 1;

database/light/session_light.ml

@@ -19,7 +19,8 @@
 
 (* shorthands *)
 module DT = DbTypes
-let sprintf = Printf.sprintf
+module String = BaseString
+let sprintf fmt = Printf.sprintf fmt
 
 (* debug *)
 #<Debugvar:DEBUG_DB>
@@ -77,18 +78,18 @@ let sprintf = Printf.sprintf
   (*******************)
 
   let write_trans dbm trans =
-    List.iter (fun (path,query) ->
-                 match query with
-                 | Tr.Set datas ->
-                     #<If>Logger.log ~color:`magenta "DB-LIGHT : updating path %s to %s"
-                                                             (Path.to_string path) (Datas.to_string datas)#<End>;
-                     Dbm.replace dbm (Encode_light.encode_path path) (Encode_light.encode_datas datas)
-                 | Tr.Remove path ->
-                     (* TODO: subtrees!!! *)
-                     #<If>Logger.log ~color:`magenta "DB-LIGHT : (qm) removing path %s" (Path.to_string path)#<End>;
-                     try Dbm.remove dbm (Encode_light.encode_path path)
-                     with Dbm.Dbm_error "dbm_delete" -> ()
-              ) (List.rev trans.Tr.tr_query_map);
+    List.iter
+      (fun (_i,path,query) ->
+         match query with
+         | Tr.Set datas ->
+             #<If>Logger.log ~color:`magenta "DB-LIGHT(%d) : updating path %s to %s"
+                                             _i (Path.to_string path) (Datas.to_string datas)#<End>;
+             Dbm.replace dbm (Encode_light.encode_path path) (Encode_light.encode_datas datas)
+         | Tr.Remove path ->
+             #<If>Logger.log ~color:`magenta "DB-LIGHT(%d) : (qm) removing path %s" _i (Path.to_string path)#<End>;
+             try Dbm.remove dbm (Encode_light.encode_path path)
+             with Dbm.Dbm_error "dbm_delete" -> ())
+      (Tr.get_sorted_queries trans);
     List.iter (fun path ->
                  #<If>Logger.log ~color:`magenta "DB-LIGHT : (rl) removing path %s" (Path.to_string path)#<End>;
                  try Dbm.remove dbm (Encode_light.encode_path path)
@@ -221,8 +222,8 @@ let sprintf = Printf.sprintf
     let t = { t with is_weak = is_weak; with_dot = with_dot; } in
     let db =
       try restart_db_from_last t
-      with exn ->
-        #<If>Logger.log "restart_db:  Can't open Dbm %s %s" file (Printexc.to_string exn)#<End>;
+      with _exn ->
+        #<If>Logger.log "restart_db:  Can't open Dbm %s %s" file (Printexc.to_string _exn)#<End>;
         raise (Open (None, "Corrupted files"))
     in
     t.db_ref <- db;
@@ -413,7 +414,8 @@ let sprintf = Printf.sprintf
             t.session_lock <- None;
             true
           with
-          | Db_light.UnqualifiedPath | DiskError _ -> false
+          | Db_light.UnqualifiedPath | DiskError _ ->
+              false
         in
         if success then begin
           #<If> Logger.info "Finished a commit." #<End>