# # add_file "git.ml" # # patch "Makefile" # from [708d8e7dcb45b060fa892a40b91495e259c3fd36] # to [468184ae6dd5fb915d9d1a1b6a64854cb829c38e] # # patch "database.ml" # from [d684e0564eaf8ace401d77b61906873c706f73f9] # to [bfbc64267c32b93b83e8d14b1414352d0b6ddb6d] # # patch "database.mli" # from [587a34962c95fe2a1837b5df23e38a1c8acc3cbd] # to [0f26f7c44b6aad6c24d2ac7809d6ac8868bcbbaa] # # patch "git.ml" # from [] # to [a920f37d4b4f0c9e83407224bdfe47e2317ff920] # # patch "ui.ml" # from [993ceff439efadcd68bd16487fe25a9b60650b8f] # to [7d827512c7a6b458a55372e159cfc7048e1ae789] # --- Makefile +++ Makefile @@ -58,6 +58,11 @@ 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 +++ database.ml @@ -306,6 +306,7 @@ +let kind = `FILE let open_db fname = if not (Sys.file_exists fname) --- database.mli +++ database.mli @@ -1,7 +1,9 @@ open Viz_types type t +val kind : [`DIRECTORY | `FILE] + (** Any of these function can raise Viz_types.Error *) val open_db : string -> t --- git.ml +++ git.ml @@ -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 --- ui.ml +++ ui.ml @@ -330,7 +330,8 @@ 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 ;