The unified diff between revisions [d1b9ae2c..] and [57124cc8..] is displayed below. It can also be downloaded as a raw diff.
#
#
# add_file "git.ml"
# content [a920f37d4b4f0c9e83407224bdfe47e2317ff920]
#
# patch "Makefile"
# from [708d8e7dcb45b060fa892a40b91495e259c3fd36]
# to [468184ae6dd5fb915d9d1a1b6a64854cb829c38e]
#
# patch "database.ml"
# from [d684e0564eaf8ace401d77b61906873c706f73f9]
# to [bfbc64267c32b93b83e8d14b1414352d0b6ddb6d]
#
# patch "database.mli"
# from [587a34962c95fe2a1837b5df23e38a1c8acc3cbd]
# to [0f26f7c44b6aad6c24d2ac7809d6ac8868bcbbaa]
#
# patch "ui.ml"
# from [993ceff439efadcd68bd16487fe25a9b60650b8f]
# to [7d827512c7a6b458a55372e159cfc7048e1ae789]
#
============================================================
--- git.ml a920f37d4b4f0c9e83407224bdfe47e2317ff920
+++ git.ml a920f37d4b4f0c9e83407224bdfe47e2317ff920
@@ -0,0 +1,235 @@
+open Viz_misc
+open Viz_types
+
+type id = string
+
+type commit = {
+ tree : id ;
+ parents : id list ;
+ author : string ;
+ committer : string ;
+ log : string ;
+ }
+
+type changeset = (string * Revision_types.change list) list
+
+type t = {
+ base : string ;
+ git_kind : [`LINUS|`PASKY] ;
+ head : id ;
+ get_commit : (string -> commit) ;
+ get_changeset : (string -> changeset)
+ }
+
+
+
+let fetch_commit_object base id =
+ if Viz_misc.debug "exec"
+ then Printf.eprintf "### exec: Running 'cat-file commit %s'\n%!" id ;
+ match Gspawn.sync
+ ~working_directory:base
+ ~flags:[`SEARCH_PATH]
+ ["cat-file"; "commit"; id] with
+ | Gspawn.EXITSTATUS 0, stdout, _ -> stdout
+ | _, _, stderr ->
+ Viz_types.errorf "cat-file invocation failed: '%s'" stderr
+
+exception Done of commit
+let scan_commit_object co =
+ let lines = string_split ~collapse:false '\n' co in
+ let c = { tree = "" ; parents = [] ; author = "" ; committer = "" ; log = "" } in
+ try
+ ignore (
+ List.fold_left (fun (c, p) l ->
+ let new_c =
+ if string_is_prefix "tree " l
+ then Scanf.sscanf l "tree %40[0-9a-f]" (fun s -> { c with tree = s })
+ else if string_is_prefix "parent" l
+ then Scanf.sscanf l "parent %40[0-9a-f]" (fun s -> { c with parents = s :: c.parents })
+ else if string_is_prefix "author" l
+ then { c with author = string_slice ~s:7 l }
+ else if string_is_prefix "committer" l
+ then { c with committer = string_slice ~s:10 l }
+ else if l = ""
+ then raise (Done ({ c with log = string_slice ~s:(p+1) co }))
+ else c in
+ new_c, p + String.length l + 1)
+ (c, 0) lines) ; assert false
+ with Done c -> c
+
+let get_commit_object base id =
+ scan_commit_object (fetch_commit_object base id)
+
+
+
+
+let fetch_changeset base old_id new_id =
+ if Viz_misc.debug "exec"
+ then Printf.eprintf "### exec: Running 'diff-tree %s %s'\n%!" old_id new_id ;
+ let tmp_file = Filename.temp_file "git-viz_" ".diff-tree" in
+ match Gspawn.sync
+ ~working_directory:base
+ ~flags:[]
+ [ "/bin/sh"; "-c" ;
+ Printf.sprintf "diff-tree '%s' '%s' > %s" old_id new_id (Filename.quote tmp_file)] with
+ | Gspawn.EXITSTATUS 0, _, _ ->
+ let stdout = with_file_in input_channel tmp_file in
+ Sys.remove tmp_file ;
+ stdout
+ | _, _, stderr ->
+ Viz_types.errorf "diff-tree invocation failed: '%s'" stderr
+
+let scan_change_linus l =
+ let b = Scanf.Scanning.from_string l in
+ match l.[0] with
+ | '+' | '-' ->
+ Scanf.bscanf b
+ "%c%_o %[0-9a-f] %n"
+ (fun c id s ->
+ if c = '+'
+ then Revision_types.ADD_FILE (string_slice ~s:(s-1) l)
+ else Revision_types.DELETE_FILE (string_slice ~s:(s-1) l))
+ | '*' ->
+ Scanf.bscanf b
+ "*%_o->%_o %[0-9a-f]->%[0-9a-f] %n"
+ (fun id1 id2 s -> Revision_types.PATCH (string_slice ~s:(s-1) l, id1, id2))
+ | _ ->
+ failwith "Could not parse changeset"
+
+let scan_change_pasky l =
+ let a = Array.of_list (string_split '\t' l) in
+ match l.[0] with
+ | '+' | '-' ->
+ begin
+ match l.[0], a.(1) with
+ | '+', _ -> Revision_types.ADD_FILE a.(3)
+ | '-', "blob" -> Revision_types.DELETE_FILE a.(3)
+ | '-', "tree" -> Revision_types.DELETE_DIR a.(3)
+ | _ -> failwith ""
+ end
+ | '*' ->
+ Revision_types.PATCH (a.(3), string_slice ~e:40 a.(2), string_slice ~s:(-40) a.(2))
+ | _ ->
+ failwith "Could not parse changeset"
+
+let scan_change = function `LINUS -> scan_change_linus | `PASKY -> scan_change_pasky
+
+let get_changes k base id1 id2 =
+ List.fold_left
+ (fun acc l -> try scan_change k l :: acc with Failure _ ->
+ Printf.eprintf "parse failure for '%s'\n%!" l ; acc)
+ []
+ (string_split '\000' (fetch_changeset base id1 id2))
+
+let get_changeset k base get_commit id =
+ let c = get_commit id in
+ List.map
+ (fun id_old ->
+ let c_old = get_commit id_old in
+ id_old, get_changes k base c_old.tree c.tree)
+ c.parents
+
+
+let kind = `DIRECTORY
+
+let open_db db_name =
+ let dl = Filename.concat db_name ".dircache" in
+ let ds = Filename.concat db_name ".git" in
+ try
+ let d, kind =
+ if Sys.file_exists dl then dl, `LINUS else
+ if Sys.file_exists ds then ds, `PASKY else failwith "unknown" in
+ let head = with_file_in input_channel (Filename.concat d "HEAD") in
+ let get_commit = Viz_misc.make_cache (get_commit_object db_name) in
+ let get_changeset = Viz_misc.make_cache (get_changeset kind db_name get_commit) in
+ { base = db_name ;
+ git_kind = kind ;
+ head = head ;
+ get_commit = get_commit ;
+ get_changeset = get_changeset }
+ with Failure _ | Sys_error _ ->
+ Viz_types.errorf "Not a git db: %s" db_name
+
+let close_db _ = ()
+
+let get_filename d = d.base
+
+let fetch_branches d = []
+
+let fetch_ancestry_graph d _ =
+ let rec proc ag id =
+ let c = d.get_commit id in
+ let node = { id = id ;
+ kind = if List.length c.parents > 1 then MERGE else REGULAR ;
+ family = List.map (fun i -> i, PARENT) c.parents } in
+ let n_ag =
+ { ag with nodes = NodeMap.add id node ag.nodes ;
+ ancestry = List.fold_left (fun e p -> EdgeMap.add (p, id) SAME_BRANCH e) ag.ancestry c.parents } in
+ List.fold_left proc n_ag c.parents in
+ proc Viz_types.empty_agraph d.head
+
+
+let fetch_revision d id =
+ { revision_id = id ;
+ manifest_id = (d.get_commit id).tree ;
+ revision_set = d.get_changeset id ;
+ certs = []
+ }
+
+let fetch_certs_and_revision d id =
+ let fake_cert = { c_id = id ;
+ c_name = "" ; c_value = "" ;
+ c_signer_id = "" ; c_signature = SIG_OK } in
+ let c = d.get_commit id in
+ { (fetch_revision d id) with certs = [
+ { fake_cert with c_name = "author" ; c_value = c.author } ;
+ { fake_cert with c_name = "committer" ; c_value = c.committer } ;
+ { fake_cert with c_name = "changelog" ; c_value = c.log } ]
+ }
+
+(* for autocolor by keyid *)
+let fetch_cert_signer d id n = []
+
+(* for autocolor *)
+let fetch_cert_value d id = function
+ | "author" -> [
+ let a = (d.get_commit id).author in
+ try Scanf.sscanf a "%s@>" (fun id -> id) with _ -> a
+ ]
+ | _ -> []
+
+(* find by tag *)
+let get_matching_tags d p = []
+
+(* autocolor by keyid *)
+let get_key_rowid d k = 0
+
+(* diff *)
+let run_monotone_diff d exe (parent, child) status cb =
+ match d.git_kind with
+ | `LINUS ->
+ ignore (Glib.Idle.add (fun () ->
+ cb (`SUB_PROC_ERROR "Diffs are not suported with git yet") ;
+ false))
+ | `PASKY ->
+ let cmd = [ "git"; "diff"; parent; child] in
+ if Viz_misc.debug "### exec"
+ then Printf.eprintf "### exec: Running '%s'\n%!" (String.concat " " cmd) ;
+ try
+ status#push "Running git diff ..." ;
+ ignore (
+ Subprocess.spawn_out
+ ~encoding:`LOCALE ~cmd
+ ~reap_callback:status#pop
+ (fun ~exceptions ~stdout ~stderr status ->
+ if status <> 0 then
+ if stderr = ""
+ then
+ error "git diff exited with status %d:\n%s" status
+ (String.concat "\n" (List.map Printexc.to_string exceptions))
+ else
+ error "git diff error:\n%s" stderr
+ else
+ cb (`DIFF stdout)))
+ with Gspawn.Error (_, msg) ->
+ Viz_types.errorf "Could not execute monotone:\n%s" msg
============================================================
--- Makefile 708d8e7dcb45b060fa892a40b91495e259c3fd36
+++ Makefile 468184ae6dd5fb915d9d1a1b6a64854cb829c38e
@@ -58,6 +58,11 @@ endif
monotone-viz : MLLIBS = str.cma lablgtk.cma gtkInit.cmo lablgnomecanvas.cma
endif
+git-viz:
+ mv database.ml database-mt.ml ; mv git.ml database.ml
+ $(MAKE) monotone-viz
+ mv database.ml git.ml ; mv database-mt.ml database.ml
+
lib3rdparty.a : mlsqlite/ocaml-sqlite3.o glib/ocaml-gspawn.o glib/ocaml-giochannel.o crypto/ocaml-openssl.o
ar crs lib3rdparty.a $(MONOTONE_DIR)/sqlite/lib3rdparty_a-*.o $^
============================================================
--- database.ml d684e0564eaf8ace401d77b61906873c706f73f9
+++ database.ml bfbc64267c32b93b83e8d14b1414352d0b6ddb6d
@@ -306,6 +306,7 @@ let sqlite_try f db =
+let kind = `FILE
let open_db fname =
if not (Sys.file_exists fname)
============================================================
--- database.mli 587a34962c95fe2a1837b5df23e38a1c8acc3cbd
+++ database.mli 0f26f7c44b6aad6c24d2ac7809d6ac8868bcbbaa
@@ -2,6 +2,8 @@ type t
type t
+val kind : [`DIRECTORY | `FILE]
+
(** Any of these function can raise Viz_types.Error *)
val open_db : string -> t
============================================================
--- ui.ml 993ceff439efadcd68bd16487fe25a9b60650b8f
+++ ui.ml 7d827512c7a6b458a55372e159cfc7048e1ae789
@@ -330,7 +330,8 @@ let make w ~aa ~prefs =
let open_dialog = lazy
begin
let dialog = GWindow.file_chooser_dialog
- ~action:`OPEN ~parent:w
+ ~action:(match Database.kind with `FILE -> `OPEN | `DIRECTORY -> `SELECT_FOLDER)
+ ~parent:w
~title:"Open a Monotone database" () in
dialog#add_button_stock `CLOSE `CLOSE ;
dialog#add_select_button_stock `OPEN `OPEN ;