# # patch "database.ml" # from [d175953b39d064060c10e7e83020819b29e10ad7] # to [82e51dcfdfe30df1cb1b9b3b6d67b4741577333c] # # patch "unidiff.ml" # from [d2a54e9183e027c92faee8c6a7eec008478876ee] # to [8364675a96bfe736ac395bc7f4924ddfa2755928] # # patch "view.ml" # from [dbcb45ab8a8bb701ddbc8c31b443457eea731a8e] # to [9adb759b137d216ad689d2662438c0cfe20b301f] # ======================================================================== --- database.ml d175953b39d064060c10e7e83020819b29e10ad7 +++ database.ml 82e51dcfdfe30df1cb1b9b3b6d67b4741577333c @@ -14,6 +14,7 @@ then Sqlite3.trace_set db (fun s -> prerr_string "### sql: " ; prerr_endline s) ; + Sqlite3.exec db "PRAGMA temp_store = MEMORY" ; Sqlite3.create_fun_1 db "unbase64" (fun s -> `TEXT (monot_decode (Sqlite3.value_text s))) let fetch_pubkeys db tbl = @@ -44,81 +45,106 @@ let id_set_add_if t v s = if t && v <> "" then IdSet.add v s else s -let add_node id in_set rel_id rel nodes = - if id = "" then nodes else begin - let current_node = - try NodeMap.find id nodes - with Not_found -> - { id = id ; - kind = if in_set - then REGULAR - else (if rel = CHILD then NEIGHBOUR_IN else NEIGHBOUR_OUT) ; - family = [] } in - let new_node = - if rel_id <> "" && not (List.mem_assoc rel_id current_node.family) - then { current_node with family = (rel_id, rel) :: current_node.family } - else current_node in - NodeMap.add id new_node nodes - end +let add_node kind id rel_id rel nodes = + try + let current_node = NodeMap.find id nodes in + if List.mem_assoc rel_id current_node.family + then + nodes + else + NodeMap.add id + { current_node with family = (rel_id, rel) :: current_node.family } + nodes + with Not_found -> + NodeMap.add id + { id = id ; kind = kind ; family = [ rel_id, rel ] } + nodes -let process_ancestry_row g = function - | [| parent; parent_mem; child; child_mem |] -> - let parent_mem = bool_of_sql_string parent_mem in - let child_mem = bool_of_sql_string child_mem in - { nodes = (add_node parent parent_mem child CHILD ( - add_node child child_mem parent PARENT g.nodes)) ; - ancestry = - if parent <> "" && child <> "" - then - EdgeMap.add (parent, child) - (if parent_mem && child_mem then SAME_BRANCH else BRANCHING) - g.ancestry - else g.ancestry ; +let process_ancestry_row g parent parent_kind child child_kind = + assert (parent_kind = REGULAR || child_kind = REGULAR) ; + assert (parent <> "" && child <> "") ; + { nodes = (add_node parent_kind parent child CHILD ( + add_node child_kind child parent PARENT g.nodes)) ; - neighbour_nodes = (id_set_add_if (not parent_mem) parent ( - id_set_add_if (not child_mem) child - g.neighbour_nodes)) } + ancestry = + EdgeMap.add (parent, child) + (if parent_kind = REGULAR && child_kind = REGULAR + then SAME_BRANCH + else BRANCHING) + g.ancestry ; + + neighbour_nodes = (id_set_add_if (parent_kind <> REGULAR) parent ( + id_set_add_if (child_kind <> REGULAR) child + g.neighbour_nodes)) + } + +let process_ancestry_row_child g = function + | [| "" ; child ; _ |] -> + if NodeMap.mem child g.nodes + then g + else + let new_node = { id = child ; kind = REGULAR ; family = [] } in + let nodes = NodeMap.add child new_node g.nodes in + { g with nodes = nodes } + + | [| parent ; child ; parent_in_query |] -> + let parent_kind = + if bool_of_sql_string parent_in_query + then REGULAR + else NEIGHBOUR_IN in + process_ancestry_row g + parent parent_kind + child REGULAR | _ -> g +let process_ancestry_row_parent g = function + | [| parent ; child |] -> + process_ancestry_row g + parent REGULAR + child NEIGHBOUR_OUT + | _ -> g + + let auto_cl_re = [ Str.regexp "\\(\\(explicit_\\)?merge of\\|propagate \\(of\\|from\\)\\) ", MERGE ; Str.regexp "disapproval of ", DISAPPROVE ] let re_match s (re, _) = Str.string_match re s 0 +let may_find f l = try Some (List.find f l) with Not_found -> None + let process_changelog_row g = function | [| id; cl |] -> - let cl = monot_decode cl in - if not (List.exists (re_match cl) auto_cl_re) - then g else begin - let (_, kind) = List.find (re_match cl) auto_cl_re in - let node = - try NodeMap.find id g.nodes - with Not_found -> assert false (* monotone db is inconsistent *) in - let updated_edges = - if kind = DISAPPROVE - then begin - let pid = - try list_rassoc PARENT node.family - with Not_found -> assert false in - let a = EdgeMap.add (pid, id) DISAPPROVED g.ancestry in - try - let pnode = NodeMap.find pid g.nodes in - let gpid = list_rassoc PARENT pnode.family in - EdgeMap.add (gpid, pid) DISAPPROVED a - with Not_found -> a - end - else g.ancestry in - let updated_nodes = - if kind <> node.kind - then NodeMap.add id { node with kind = kind } g.nodes - else g.nodes in - { g with ancestry = updated_edges ; nodes = updated_nodes } + begin + let cl = monot_decode cl in + match may_find (re_match cl) auto_cl_re with + | None -> g + | Some (_, kind) -> + let node = NodeMap.find id g.nodes in + let updated_edges = + if kind = DISAPPROVE + then begin + try + let pid = list_rassoc PARENT node.family in + let a = EdgeMap.add (pid, id) DISAPPROVED g.ancestry in + try + let pnode = NodeMap.find pid g.nodes in + let gpid = list_rassoc PARENT pnode.family in + EdgeMap.add (gpid, pid) DISAPPROVED a + with Not_found -> a + with Not_found -> g.ancestry + end + else g.ancestry in + let updated_nodes = + if kind <> node.kind + then NodeMap.add id { node with kind = kind } g.nodes + else g.nodes in + { g with ancestry = updated_edges ; nodes = updated_nodes } end | _ -> g - + let process_branching_edge_row g = function | [| parent; child |] -> { g with ancestry = EdgeMap.add (parent, child) BRANCHING g.ancestry } @@ -134,10 +160,15 @@ (* grab all node ids and edges we're interested in *) let agraph = - Sqlite3.fetch_f db process_ancestry_row agraph - "SELECT parent, parent IN %s, child, child IN %s FROM revision_ancestry \ - WHERE parent IN %s OR child IN %s" view_name view_name view_name view_name in + Sqlite3.fetch_f db process_ancestry_row_child agraph + "SELECT parent, child, parent IN %s \ + FROM revision_ancestry WHERE child IN %s" view_name view_name in + let agraph = + Sqlite3.fetch_f db process_ancestry_row_parent agraph + "SELECT parent, child \ + FROM revision_ancestry WHERE parent IN %s AND child NOT IN %s" view_name view_name in + (* look at changelogs to decide what nodes are 'uninteresting' (ie merge or disapproval nodes) *) let agraph = @@ -154,21 +185,17 @@ agraph | _ -> (* we need another database query *) - (* unfortunaltely, it doesn't seem to work with - the new sqlite query optimizer *) - let v = Sqlite3.version () in - if "3.2.3" <= v && v <= "3.2.5" - then agraph - else - Sqlite3.fetch_f db - process_branching_edge_row agraph - "SELECT A.parent, A.child \ - FROM revision_ancestry AS A, revision_certs AS C, revision_certs AS P \ - WHERE (C.id IN %s OR P.id IN %s) AND \ - C.id = A.child AND P.id = A.parent AND \ - C.name = 'branch' AND P.name = 'branch' AND \ - C.value != P.value" - view_name view_name + Sqlite3.fetch_f db + process_branching_edge_row agraph + "SELECT parent, child \ + FROM revision_ancestry AS A \ + WHERE A.child IN %s AND A.parent != '' AND \ + NOT EXISTS \ + (SELECT P.id FROM revision_certs AS C, revision_certs AS P \ + WHERE C.id = A.child AND P.id = A.parent \ + AND C.name = 'branch' AND P.name = 'branch' \ + AND C.value = P.value)" + view_name end in (* reconnect disconnected components *) ======================================================================== --- unidiff.ml d2a54e9183e027c92faee8c6a7eec008478876ee +++ unidiff.ml 8364675a96bfe736ac395bc7f4924ddfa2755928 @@ -148,7 +148,7 @@ let sw = GBin.scrolled_window ~packing:(vbox#pack ~expand:true) () in let v = GText.view ~buffer ~cursor_visible:false ~editable:false - ~width:500 ~height:300 ~packing:sw#add () in + ~width:675 ~height:300 ~packing:sw#add () in v#misc#modify_font_by_name "Monospace" ; v#misc#grab_focus () ; ignore ======================================================================== --- view.ml dbcb45ab8a8bb701ddbc8c31b443457eea731a8e +++ view.ml 9adb759b137d216ad689d2662438c0cfe20b301f @@ -409,7 +409,10 @@ select_signal = Signal.make () } in begin let callback () = - ignore (Glib.Idle.add (fun () -> select_branch c ; false)) in + ignore (Glib.Idle.add (fun () -> + try select_branch c ; false + with Viz_types.Error msg -> + error_notice ~parent:hb msg ; false)) in let (combo, _) = combo in c.combo_signal <- Some (combo#connect#changed ~callback) ; ignore (checkb#connect#toggled ~callback)