Permalink
Browse files

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

  • Loading branch information...
1 parent 1db6f11 commit 12236eed0dd175f5378b59732f8657adf5f8e76f @nrs135 nrs135 committed with Louis Gesbert Jun 29, 2011
View
11 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) ->
View
8 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
View
1 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
View
57 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 *)
View
44 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
View
32 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;
View
34 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>
View
156 database/light/transaction_light.ml
@@ -19,7 +19,9 @@
(* shorthands *)
module DT = DbTypes
+module String = BaseString
module List = BaseList
+module Hashtbl = BaseHashtbl
let sprintf = Printf.sprintf
let eprintf = Printf.eprintf
@@ -37,20 +39,26 @@ let string_of_query = function
| Remove k -> sprintf "remove %s" (Path.to_string k)
let string_of_query_list list =
- List.to_string (fun q -> sprintf "%s " (string_of_query q)) list
+ List.to_string (fun (i,_,q) -> sprintf "%d:%s " i (string_of_query q)) list
-let string_of_query_map qm =
- List.to_string (fun (p,q) -> sprintf "(%s,%s); " (Path.to_string p) (string_of_query q)) qm
+type query_element = (int * Path.t * query)
+type query_map = (Path.t, query_element list) Hashtbl.t
+
+let string_of_query_element (i,_,q) = sprintf "%d:%s " i (string_of_query q)
+
+let string_of_query_map (qm:query_map) =
+ let qs = Hashtbl.fold (fun p ql a -> (p,ql)::a) qm [] in
+ List.to_string (fun (p,ql) -> sprintf "(%s,%s); " (Path.to_string p) (string_of_query_list ql)) qs
type t = {
tr_num : int ;
tr_db : Db_light.t ;
(** the db the transaction refers to *)
- tr_query_map : (Path.t * query) list;
+ tr_query_map : query_map;
(** the map of queries against the db *)
- tr_remove_list : Path.t list ;
+ mutable tr_remove_list : Path.t list;
(** the list of deleted paths in the transaction *)
tr_index_set : (Path.t * DataImpl.t) list ;
@@ -93,22 +101,23 @@ let rec find_data_in_query_list = function
| Set (Datas.Copy (_, _)) :: _ -> assert false
| _ :: tl -> find_data_in_query_list tl
+exception Datas_not_found
+
+let rec find_datas_in_query_list = function
+ | [] -> raise Datas_not_found
+ | (_,_,Set datas) :: _ -> datas
+ | _ :: tl -> find_datas_in_query_list tl
+
exception Removed
(* Raises [Not_found] if data absent from query, [Removed] if removed. *)
let get_query_at tr path =
- let query_list =
- List.fold_left
- (fun query_list (p,q) ->
- if Path.compare path p = 0
- then (p,q)::query_list
- else query_list) [] tr.tr_query_map
- in
+ let query_list = Option.default [] (Hashtbl.find_opt tr.tr_query_map path) in
if query_list = []
then
- if List.mem path tr.tr_remove_list
- then raise Removed
- else raise Not_found;
+ (if List.mem path tr.tr_remove_list
+ then raise Removed
+ else raise Not_found);
query_list
let rec find_set_data_in_query_list = function
@@ -135,13 +144,46 @@ let stat tr path =
in
(path, Some (Revision.make 0), kind)
+let datas_from_path tr path = Node_light.get_content (Db_light.node_node (snd (Db_light.follow_link tr.tr_db path)))
+
+let rec unwind tr path =
+ let datas =
+ match Option.default [] (Hashtbl.find_opt tr.tr_query_map path) with
+ | [] ->
+ let datas = datas_from_path tr path in
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : unwind %s -> %s" (Path.to_string path) (Datas.to_string datas)#<End>;
+ datas
+ | qlist ->
+ (try
+ let datas = find_datas_in_query_list qlist in
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : unwind(qlist) %s -> %s"
+ (Path.to_string path) (Datas.to_string datas)#<End>;
+ datas
+ with Datas_not_found ->
+ let datas = datas_from_path tr path in
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : unwind(noset) %s -> %s" (Path.to_string path)
+ (Datas.to_string datas)#<End>;
+ datas)
+ in
+ match datas with
+ | Datas.Data _ -> datas
+ | Datas.Link p -> unwind tr p
+ | Datas.Copy (_, p) -> unwind tr p
+ | Datas.UnsetData -> datas
+
let get tr path =
- #<If>Logger.log ~color:`yellow "DB-LIGHT : get data at %s" (Path.to_string path)#<End>;
- let (_path, node) = Db_light.follow_link tr.tr_db path in
- Db_light.get_data tr.tr_db (Db_light.node_node node)
+ let data =
+ match unwind tr path with
+ | Datas.Data d -> d
+ | Datas.UnsetData -> DataImpl.empty
+ | _ -> assert false
+ in
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : get data at %s = %s" (Path.to_string path) (DataImpl.to_string data)#<End>;
+ data
(* may raise Removed and Not_found *)
-let virtual_get_children tr path = List.map fst (get_query_at tr path)
+let virtual_get_children tr path =
+ Hashtbl.fold (fun p _ a -> if Path.is_prefix path p then p::a else a) tr.tr_query_map []
let get_children tr range path =
#<If>Logger.log ~color:`yellow "DB-LIGHT : get children at %s" (Path.to_string path)#<End>;
@@ -150,13 +192,8 @@ let get_children tr range path =
let virtual_children = List.sort compare virtual_children in
try
let real_children = Db_light.get_children tr.tr_db None path in
- let real_children = List.filter
- (fun p -> not (List.mem p tr.tr_remove_list)) real_children
- in
- let l =
- BaseList.uniq (List.merge (fun p1 p2 -> Path.compare p1 p2)
- virtual_children real_children)
- in
+ let real_children = List.filter (fun p -> not (List.mem p tr.tr_remove_list)) real_children in
+ let l = BaseList.uniq (List.merge (fun p1 p2 -> Path.compare p1 p2) virtual_children real_children) in
(* If we got there, it's the 1% of cases where
the queried children are affected by the current transaction. *)
BaseList.filterbounds range (fun p -> Path.last p) l
@@ -176,12 +213,17 @@ let trans_operation_counter_limit =
0
#<End>
+let query_index = ref 0
+let get_query_index () = incr query_index; !query_index
+
let add_to_query_map =
let do_it tr path (query:query) =
#<If$minlevel 3>Logger.log ~color:`blue
"Transaction_light.add_to_query_map: path=%s query=%s"
(Path.to_string path) (string_of_query query)#<End>;
- { tr with tr_query_map = (path, query) :: tr.tr_query_map }
+ Hashtbl.replace tr.tr_query_map path
+ ((get_query_index(),path,query)::(Option.default [] (Hashtbl.find_opt tr.tr_query_map path)));
+ tr
in
(* enable the transaction count limit (plus some checks) if requested *)
if trans_operation_counter_limit == 0 then do_it
@@ -222,6 +264,10 @@ let rm_all_with_prefix path l =
let remove_from_query_map qm path = List.filter (fun (p,_) -> Path.compare path p <> 0) qm
+let remove_subtree path tr =
+ let rl = Hashtbl.fold (fun p _ a -> if Path.is_prefix path p then p::a else a) tr.tr_query_map [] in
+ List.iter (fun p -> Hashtbl.remove tr.tr_query_map p) rl
+
let set_link tr path link =
#<If>
Logger.log ~color:`yellow
@@ -234,12 +280,12 @@ let set_link tr path link =
let query = Set (Datas.Link link) in
(* This removes additions to the whole subtree,
because link node makes them all inaccessible. *)
- let new_map = remove_from_query_map tr.tr_query_map path in
- let tr = { tr with tr_query_map = new_map } in
+ remove_subtree path tr;
let tr = add_to_query_map tr path query in
(* We don't have to remove anything below [path],
so we remove all paths that begin with [path] from remove list. *)
- { tr with tr_remove_list = rm_all_with_prefix path tr.tr_remove_list }
+ tr.tr_remove_list <- rm_all_with_prefix path tr.tr_remove_list;
+ tr
(* The check if [target_path] is dangling in [target_rev]
is done much later, in [execute_query_list], because if the copy
@@ -254,12 +300,12 @@ let set_copy tr path (target_path, _target_rev) =
let query = Set (Datas.Copy ((Some (Revision.make 0)), target_path)) in
(* This removes additions to the whole subtree,
because copy node makes them all inaccessible. *)
- let new_map = remove_from_query_map tr.tr_query_map path in
- let tr = { tr with tr_query_map = new_map } in
+ remove_subtree path tr;
let tr = add_to_query_map tr path query in
(* We don't have to remove anything below [path],
so we remove all paths that begin with [path] from remove list. *)
- { tr with tr_remove_list = rm_all_with_prefix path tr.tr_remove_list }
+ tr.tr_remove_list <- rm_all_with_prefix path tr.tr_remove_list;
+ tr
let set tr path data =
#<If>
@@ -315,7 +361,7 @@ let init db ?read_only i =
let _ = read_only in
{ tr_num = i
; tr_db = db
- ; tr_query_map = []
+ ; tr_query_map = Hashtbl.create 16
; tr_remove_list = []
; tr_index_set = []
; tr_index_remove = []
@@ -337,27 +383,49 @@ let update_node_list l uid node =
then (uid, node) :: (List.remove_assoc uid l)
else (uid, node) :: l
+let compare_q (i1,_,_) (i2,_,_) = Pervasives.compare i1 i2
+let get_sorted_queries tr = List.sort compare_q (Hashtbl.fold (fun _ ql a -> ql@a) tr.tr_query_map [])
+
let execute_query_map tr db =
#<If>Logger.log ~color:`yellow "DB-LIGHT : execute_query_map %s" (string_of_query_map tr.tr_query_map)#<End>;
+ let qs = get_sorted_queries tr in
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : execute_query_map(sorted)[%s]"
+ (String.concat_map "; " string_of_query_element qs)#<End>;
try
- let ia, ir =
+ let ia, ir, rl =
List.fold_left
- (fun (ia,ir) (path,query) ->
+ (fun (ia,ir,rl) (_i,path,query) ->
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : execute_query_map %s" (string_of_query_element (_i,path,query))#<End>;
match query with
| Set (data) ->
ignore (Db_light.update db path data);
- let d = Db_light.get tr.tr_db path in
- ((path,d)::ia,ir)
+ (match data with
+ | Datas.Data d -> ((path,d)::ia,ir,rl)
+ | Datas.UnsetData -> ((path,DataImpl.Unit)::ia,ir,rl)
+ | Datas.Link _p
+ | Datas.Copy (_,_p) ->
+ (try
+ let d = Db_light.get tr.tr_db path in
+ ((path,d)::ia,ir,rl)
+ with Db_light.UnqualifiedPath ->
+ #<If>Logger.log ~color:`red "execute_query_map: dangling link or copy %s -> %s"
+ (Path.to_string path) (Path.to_string _p)#<End>;
+ (ia,ir,rl)))
| Remove path ->
+ let ch = try Db_light.get_all_children db None path with Db_light.UnqualifiedPath -> [] in
+ #<If>Logger.log ~color:`yellow "DB-LIGHT : execute_query_map(Remove) ch=[%s]"
+ (String.concat_map "; " Path.to_string ch)#<End>;
ignore (Db_light.remove db path);
- (ia,(path,DataImpl.Unit)::ir))
- (tr.tr_index_set,tr.tr_index_remove) (List.rev tr.tr_query_map)
+ let allir = (path,DataImpl.Unit)::(List.map (fun p -> (p,DataImpl.Unit)) ch) in
+ (ia,allir@ir,ch@rl))
+ (tr.tr_index_set,tr.tr_index_remove,tr.tr_remove_list) qs
in
- { tr with tr_query_map = []; tr_index_set = ia; tr_index_remove = ir }, db
+ tr.tr_remove_list <- rl;
+ { tr with tr_index_set = ia; tr_index_remove = ir; }, db
with
| e ->
- let bt = Printexc.get_backtrace () in
- #<If> Logger.log ~color:`red "execute_query_map --> %s\n%s" (Printexc.to_string e) bt #<End>;
+ let _bt = Printexc.get_backtrace () in
+ #<If>Logger.log ~color:`red "execute_query_map --> %s\n%s" (Printexc.to_string e) _bt#<End>;
raise e
let execute_remove_list tr db =
@@ -372,7 +440,7 @@ let execute_remove_list tr db =
{ tr with tr_index_remove = (path,d)::tr.tr_index_remove }, db)
(tr, db) l
-let modified tr = not ((tr.tr_query_map = []) && (tr.tr_remove_list = []))
+let modified tr = not ((Hashtbl.length tr.tr_query_map = 0) && (tr.tr_remove_list = []))
let commit tr db =
if modified tr then begin
View
32 database/light/transaction_light.mli
@@ -15,36 +15,48 @@
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
+
+exception Data_not_found
+exception Datas_not_found
+exception Removed
+
type query = Set of Datas.t | Remove of Path.t
-val string_of_query : query -> string
-val string_of_query_list : query list -> string
-val string_of_query_map : (Path.t * query) list -> string
+type query_element = int * Path.t * query
+type query_map = (Path.t, query_element list) Hashtbl.t
type t = {
tr_num : int;
tr_db : Db_light.t;
- tr_query_map : (Path.t * query) list;
- tr_remove_list : Path.t list;
+ tr_query_map : query_map;
+ mutable tr_remove_list : Path.t list; (* for db_light we need to pass this from prepare to commit *)
tr_index_set : (Path.t * DataImpl.t) list;
tr_index_remove : (Path.t * DataImpl.t) list;
tr_op_counter : int;
}
+
+val string_of_query : query -> string
+val string_of_query_list : (int * 'a * query) list -> string
+val string_of_query_map : query_map -> string
val get_num : t -> int
val get_db : t -> Db_light.t
-val get_query_map : t -> (Path.t * query) list
+val get_query_map : t -> query_map
val full_search : t -> string list -> Path.t -> Keys.t list
-exception Data_not_found
val find_data_in_query_list : query list -> DataImpl.t
-exception Removed
-val get_query_at : t -> Path.t -> (Path.t * query) list
+val find_datas_in_query_list : ('a * 'b * query) list -> Datas.t
+val get_query_at : t -> Path.t -> query_element list
val find_set_data_in_query_list : query list -> DataImpl.t option
val stat : t -> Path.t -> Path.t * Revision.t option * [> `Data | `Link | `Unset ]
+val datas_from_path : t -> Path.t -> Datas.t
+val unwind : t -> Path.t -> Datas.t
val get : t -> Path.t -> DataImpl.t
val virtual_get_children : t -> Path.t -> Path.t list
val get_children : t -> Keys.t option * int -> Path.t -> Path.t list
val trans_operation_counter_limit : int
+val query_index : int ref
+val get_query_index : unit -> int
val add_to_query_map : t -> Path.t -> query -> t
val rm_all_with_prefix : Path.t -> Path.t list -> Path.t list
val remove_from_query_map : (Path.t * 'a) list -> Path.t -> (Path.t * 'a) list
+val remove_subtree : Path.t -> t -> unit
val set_link : t -> Path.t -> Path.t -> t
val set_copy : t -> Path.t -> Path.t * 'a -> t
val set : t -> Path.t -> DataImpl.t -> t
@@ -53,6 +65,8 @@ val remove : t -> Path.t -> t
val init : Db_light.t -> ?read_only:'a -> int -> t
val update_uid_list : ('a * 'b) list -> 'a -> 'b -> ('a * 'b) list
val update_node_list : ('a * 'b) list -> 'a -> 'b -> ('a * 'b) list
+val compare_q : 'a * 'b * 'c -> 'a * 'd * 'e -> int
+val get_sorted_queries : t -> query_element list
val execute_query_map : t -> Db_light.t -> t * Db_light.t
val execute_remove_list : t -> Db_light.t -> t * Db_light.t
val modified : t -> bool

0 comments on commit 12236ee

Please sign in to comment.