Below is the file 'git.ml' from this revision. You can also download the file.

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) ;
    tags          : (string * string) list ;
    branches      : (string * string) list ;
  }

let id_of_file ?dir f =
  with_file_in
    input_line
    (match dir with None -> f | Some d -> Filename.concat d f)

let fetch_dir_of_ids git_dir subdir =
  try
    let dir = Filename.concat git_dir subdir in
    List.map
      (fun n -> (id_of_file ~dir n, n))
      (Array.to_list (Sys.readdir dir))
  with _ -> []

let fetch_tags git_dir =
  fetch_dir_of_ids git_dir "tags"

let fetch_history base id =
  log "exec" "### exec: Running rev-tree %s'" id ;
  match Gspawn.sync
      ~working_directory:base
      ~flags:[`SEARCH_PATH]
      ["rev-tree"; id] with
  | Gspawn.EXITSTATUS 0, stdout, _ ->
      stdout
  | _, _, stderr ->
      Viz_types.errorf "rev-tree invocation failed: '%s'" stderr


let scan_history data =
  let get_id s =
    match string_split ~max_elem:2 ':' s with
    | id :: _ -> id
    | _ -> raise Not_found in

  let rec proc ag i =
    if i >= String.length data
    then ag
    else begin
      let j = String.index_from data i '\n' in
      let l = String.sub data i (j - i) in
      let ag =
	match string_split ' ' l with
	| _ :: node :: parents ->
	    let id = get_id node in
	    let parents = List.map get_id parents in
	    let node = { id = id ;
			 kind = if List.length parents > 1 then MERGE else REGULAR ;
			 family = List.map (fun i -> i, PARENT) parents } in
	    let edges =
	      List.fold_left
		(fun e p -> EdgeMap.add (p, id) SAME_BRANCH e)
		ag.ancestry parents in
	    { ag with
	      nodes = NodeMap.add id node ag.nodes ;
	      ancestry = edges }
	| _ -> ag in
      proc ag (j+1)
    end in

  proc Viz_types.empty_agraph 0

let fetch_commit_object base id =
  log "exec" "### exec: Running 'cat-file commit %s'" 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

let scan_commit_object co =
  let tree = ref "" in
  let parents = ref [] in
  let author = ref "" in
  let committer = ref "" in
  let log = ref "" in
  begin
    let lines = string_split ~collapse:false '\n' co in
    let p = ref 0 in
    try List.iter (function
      | "" -> raise Exit
      | l ->
	  p := !p + String.length l + 1 ;
	  match   string_split ~max_elem:2 ' ' l with
	  | ["tree"; id] -> tree := id
	  | ["parent"; id] -> parents := id :: !parents
	  | ["author"; v] -> author := v
	  | ["committer"; v] -> committer := v
	  | _ -> ()) lines
    with Exit ->
      log := string_slice ~s:(!p + 1) co
  end ;
  { tree = !tree ;
    parents = List.rev !parents ;
    author = !author ;
    committer = !committer ;
    log = !log }

let get_commit_object base id =
  scan_commit_object (fetch_commit_object base id)




let fetch_changeset base old_id new_id =
  log "exec" "### exec: Running 'diff-tree %s %s'" 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 ->
      Sys.remove tmp_file ;
      Viz_types.errorf "diff-tree invocation failed:\n'%s'" stderr

let scan_change_linus l =
  let b = Scanf.Scanning.from_string l in
  match l.[0] with
  | '+' | '-' ->
      Scanf.bscanf b
	"%c%_o %40[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 %40[0-9a-f]->%40[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 get_changes k base id1 id2 =
  let (sep, scan_fun) =
    match k with
    | `LINUS -> '\000', scan_change_linus
    | `PASKY -> '\n',   scan_change_pasky in
  List.fold_left
    (fun acc l -> scan_fun l :: acc)
    []
    (string_split sep (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 ds then ds, `PASKY else
      if Sys.file_exists dl then dl, `LINUS else failwith "unknown" in
    let head = id_of_file ~dir: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 ;
      tags = fetch_tags d ;
      branches = fetch_dir_of_ids d "heads"
    }
  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 =
  List.sort compare
    (List.map snd d.branches)

let fetch_ancestry_graph d q =
  let head =
    match q with
    | BRANCH b ->
	begin
	  try list_rassoc b d.branches
	  with Not_found -> d.head
	end
    | _ -> d.head in
  scan_history (fetch_history d.base 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
  let cert_list =
    try
      let tag = List.assoc id d.tags in
      [ { fake_cert with c_name = "tag" ; c_value = tag } ]
    with Not_found -> [] 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 } :: cert_list
  }

(* 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
    ]
  | "tag" -> begin
      try [ List.assoc id d.tags ]
      with Not_found -> []
  end
  | _ -> []

(* find by tag *)
let get_matching_tags d p =
  List.filter
    (fun (_, t) -> p t)
    d.tags

(* find by date *)
let get_matching_dates d s = []

(* 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
      log "exec" "### exec: Running '%s'" (String.concat " " cmd) ;
      try
	status#push "Running git diff ..." ;
	ignore (
	Subprocess.spawn_out
	  ~working_directory:d.base
	  ~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