The unified diff between revisions [c0298de2..] and [fac83dcc..] is displayed below. It can also be downloaded as a raw diff.
#
#
# delete "crypto"
#
# delete "crypto/crypto.ml"
#
# delete "crypto/crypto.mli"
#
# delete "crypto/ocaml-openssl.c"
#
# delete "database.ml"
#
# delete "database.mli"
#
# delete "extlib-1.3"
#
# delete "extlib-1.3/IO.ml"
#
# delete "extlib-1.3/IO.mli"
#
# delete "extlib-1.3/unzip.ml"
#
# delete "extlib-1.3/unzip.mli"
#
# delete "mlsqlite"
#
# delete "mlsqlite/config.h"
#
# delete "mlsqlite/ocaml-sqlite3.c"
#
# delete "mlsqlite/ocaml-sqlite3.h"
#
# delete "mlsqlite/sqlite3.ml"
#
# delete "mlsqlite/sqlite3.mli"
#
# delete "ocamlnet-0.97.1"
#
# delete "ocamlnet-0.97.1/LICENSE"
#
# delete "ocamlnet-0.97.1/base64.ml"
#
# delete "ocamlnet-0.97.1/base64.mli"
#
# delete "revision_lexer.mll"
#
# delete "revision_parser.mly"
#
# delete "revision_types.mli"
#
# delete "schema_lexer.mll"
#
# add_file "automate.ml"
# content [bc697ff6c3768259b1838e5638552f448433b53a]
#
# add_file "automate.mli"
# content [27a0f822b26d9b436416f597c5a079f3f45bb784]
#
# add_file "basic_io_lexer.mli"
# content [20d5687ac500fa12ef010d839f80d7a7f5d05aea]
#
# add_file "basic_io_lexer.mll"
# content [ba4720c3e3ad4457f5c75e1caf20cc562cda77f3]
#
# add_file "monotone.ml"
# content [9fa93c28a72357c18adcafd38846c461a6be6845]
#
# add_file "monotone.mli"
# content [a629c1ce8cc72db8296bc3dc8433f1f2ce8ead9e]
#
# add_file "revision.ml"
# content [ed65760918027461605d1691fd2fc6f50e63cc47]
#
# add_file "revision.mli"
# content [c55251affdd8ab000599767b9e473cab8ad23b0b]
#
# patch "INSTALL"
# from [656dd842a340729b89f5d42611d01db59800d7ef]
# to [e80e9f3656f902f59c2adb63b6ce5c09ff165a55]
#
# patch "Makefile"
# from [959a7ff9f2703b28fd79c4a0fbb073ed1d27f353]
# to [e2382b7c2e004fd4b9c59eb1035f191ffdc5c1a3]
#
# patch "NEWS"
# from [e5dc9e771afb20d9d025ddd0cd85be9ec3d6dcba]
# to [71057e70a09a20c4d356f18b3e19f197c3c46bcd]
#
# patch "README"
# from [ca8f7f128d188deaecc95d31dc580154e53fd454]
# to [7df1a7e44da44166e93bc4d1a627c19082634036]
#
# patch "agraph.ml"
# from [5823b36800b8a29b8a9b1105ee4945620526da33]
# to [8ae6c9bb70bbf9fd80e4e62d9f162ac581619b9e]
#
# patch "app.ml"
# from [ecdd153474516d486e2ad04862b65f537522a10e]
# to [e62a81510dee75756f4a3db537240560d5ffa1b0]
#
# patch "app.mli"
# from [221b1797f90548892501681a900a80ee017d9359]
# to [81de698901b6c3e71f1b3ef78377748697b32294]
#
# patch "autocolor.ml"
# from [9d59f87e56d79aad8c632cff38b12fab557814df]
# to [940507d413a192f50208ca5723b2c99749dac513]
#
# patch "autocolor.mli"
# from [6380f588de9f3457c50c7d20846b6cc6a0d0efa9]
# to [c8ade8687ec54d7852d55545e08f92b884f08120]
#
# patch "config.make.in"
# from [93dc881513748f3dad53927c5e1f021129d40a6c]
# to [ab4dd391e36577ee261132a3e330476f043cc551]
#
# patch "configure.ac"
# from [7099114251fbf1712393a6ec463554fb3edb63df]
# to [28cc3999f3e5277dea5b79dfc04c1f8396c3af9d]
#
# patch "dot_lexer.mll"
# from [3a71fb27288b4d3e0c3162a24153e34d89358d4f]
# to [a466db6a992849b3408646516d0d8936ce334a43]
#
# patch "glib/giochannel.ml"
# from [d2f7241bdc6af475022c162be25a383f61e9624c]
# to [43e1aac62aaa993eb3864f62c709539276740411]
#
# patch "glib/giochannel.mli"
# from [0fd137687560f6951e5377ac213371df7135e53f]
# to [a2531dbc99c8c1b2f808dff1a5a6dec3d4080b8d]
#
# patch "glib/ocaml-giochannel.c"
# from [fb46e36577eb1803ec00649f0770c179b5ab71f4]
# to [6c3489c6443d057d2f3fce77a2d3465466c2ff93]
#
# patch "glib/ocaml-gspawn.c"
# from [0f9699de08507b50e004ccefdd8f513ce6c1f07d]
# to [35c4485ece72c47122caf1f0729a436f07786753]
#
# patch "gnomecanvas_hack.c"
# from [ed8e248d636d567cacfe4727a9370ee4283097af]
# to [0e28de5cf7f0ea5df027fee49bcb63056b2c27c5]
#
# patch "main.ml"
# from [4e7b15f2966740755d87d69522e02c1f47feefe9]
# to [c97fd3746cf8966dfbf158a2a49b6812a1d35feb]
#
# patch "query.ml"
# from [f691b2a902e28ebb9503a018f52a1634297b39ed]
# to [0b0ca22a8260b482a15efbee2adf6619a34119bb]
#
# patch "subprocess.ml"
# from [e1f23ae41fa3d03977419f2f102646e0ad32d546]
# to [2d064944dda534981a86b13dbc018a47bfcf5576]
#
# patch "ui.ml"
# from [89f9af8477b455fc355375fdc5edbc0f7d3a9241]
# to [11001bc610a51475ab918f26ede093f811e69e0e]
#
# patch "ui.mli"
# from [d25fe1553276726e4cd998b1010d280139e5534b]
# to [eb8ae605a812037deaa0f8bf4d9f7b3d744aed13]
#
# patch "unidiff.ml"
# from [6446132389b142a377ad1922e73e7104241c88a6]
# to [a84b8a696a2e5075b1cfe0ced654bcfe367f7002]
#
# patch "view.ml"
# from [e2d0e8ea6928c04c7002e37d08aee0c5de5a1c3e]
# to [60ed1b72ef4581b1b5bd247f86c921b877ca2384]
#
# patch "viz_misc.ml"
# from [6fd0c3f159b19117f0baf4570c3cec8b0a24aedc]
# to [962f45ead1ad16c50548c9a69a360d70940d195e]
#
# patch "viz_misc.mli"
# from [0cfad473122dc2494c4886ebf8ec3d362ef7ea5a]
# to [1ab258dd15c9db682622c137aa1bb2db6b903ee4]
#
# patch "viz_style.ml"
# from [9f453028636cbd6f0dbc058a8cbb38a4880c563e]
# to [ffc50f7030fd216bdf9de1fc1dcc3cfba295e98a]
#
# patch "viz_style.mli"
# from [0ef255a1d99f080be0f2fceb5b35bb34f9dd7644]
# to [39f0bf6b8542af069ba332237282b9eb42b873d2]
#
# patch "viz_types.ml"
# from [000e61799446f6d11caad5379ca79c9ea6ff087e]
# to [df6981aa67f5a7519900dbb06f38b96771db6919]
#
# patch "viz_types.mli"
# from [dcc5514fcad957dbccfe3b83c2878fe91dc605b0]
# to [dc1b80f54bce2e6327b1d8de16d0a5762f3293a9]
#
============================================================
--- automate.ml bc697ff6c3768259b1838e5638552f448433b53a
+++ automate.ml bc697ff6c3768259b1838e5638552f448433b53a
@@ -0,0 +1,526 @@
+open Viz_misc
+
+let init =
+ Giochannel.init ; Gspawn.init
+
+let debug = Viz_misc.debug "automate"
+
+let log fmt =
+ Printf.kprintf
+ (fun s -> Printf.eprintf "### automate: %s\n%!" s)
+ fmt
+
+
+(** Type definitions *)
+
+type pb = [
+ | `HANGUP
+ | `FAILURE
+ | `ERROR of exn ]
+type watch_state = [
+ | `DISABLED
+ | `WATCH of Giochannel.source_id
+ | pb ]
+type watch = {
+ w_name : string ;
+ w_chan : Giochannel.t ;
+ mutable w_state : watch_state ;
+ mutable exn_cb : pb -> unit ;
+ }
+type in_watch = {
+ in_w : watch ;
+ mutable in_data : (int * string) list ;
+ mutable in_pos : int ;
+ }
+type out_watch = {
+ out_w : watch ;
+ out_sb : string ;
+ out_buffer : Buffer.t ;
+ mutable out_cb : (Buffer.t -> unit)
+ }
+
+type command_id = int
+type output = [
+ | `OUTPUT of string
+ | `ERROR of string
+ | `SYNTAX_ERROR of string]
+type chunk = command_id * int * bool * string
+type process = {
+ p_in : in_watch ;
+ p_out : out_watch ;
+ p_err : out_watch ;
+ mutable cmd_number : command_id ;
+ mutable callbacks : (command_id * (output -> unit)) list ;
+ mutable chunks : (command_id * chunk list ref) list ;
+ mutable state : [`RUNNING|`EXITING|`EXIT of int] ;
+ mutable exit_cb : (pb -> string -> unit) ;
+ }
+
+
+type t = {
+ mtn : string ;
+ db_fname : string ;
+ mutable process : process option ;
+ }
+
+let get_info c =
+ c.mtn, c.db_fname
+let get_dbfname c =
+ c.db_fname
+
+
+
+let string_of_conditions cond =
+ let s = String.make 6 '.' in
+ Array.iteri
+ (fun i (v, c) -> if List.mem v cond then s.[i] <- c)
+ [| `IN, 'I' ; `OUT, 'O' ;
+ `HUP, 'H' ; `ERR, 'E' ;
+ `PRI, 'P' ; `NVAL, 'N' |] ;
+ s
+let string_of_pb = function
+ | `ERROR exn -> Printf.sprintf "EXN '%s'" (Printexc.to_string exn)
+ | `FAILURE -> "ERR"
+ | `HANGUP -> "HUP"
+
+
+
+
+let error_cb w conditions =
+ if debug then log "%s hup_cb = %s" w.w_name (string_of_conditions conditions) ;
+ if List.mem `ERR conditions
+ then begin
+ w.exn_cb `FAILURE
+ end else begin
+ assert (conditions = [`HUP]) ;
+ w.exn_cb `HANGUP
+ end
+
+
+let do_write w data =
+ let bytes_written = ref 0 in
+ try
+ match Giochannel.write_chars w.in_w.w_chan ~bytes_written ~off:w.in_pos data with
+ | `NORMAL written ->
+ if debug then log "%s cb: wrote %d" w.in_w.w_name written ;
+ w.in_pos <- w.in_pos + written ;
+ w.in_pos >= String.length data
+ | `AGAIN ->
+ (* should not happen, our out channels are blocking *)
+ if debug then log "%s cb: EAGAIN ?" w.in_w.w_name ;
+ false
+ with
+ | Giochannel.Error (_, msg) as exn ->
+ if debug then log "%s cb: error %s, wrote %d" w.in_w.w_name msg !bytes_written ;
+ w.in_w.exn_cb (`ERROR exn) ;
+ false
+
+let _write_cb w conditions =
+ if debug then log "%s cb = %s" w.in_w.w_name (string_of_conditions conditions) ;
+ match w.in_data with
+ | [] ->
+ (* nothing to write, remove the source from the main loop *)
+ if debug then log "%s cb: empty write queue, removing watch" w.in_w.w_name ;
+ w.in_w.w_state <- `DISABLED
+
+ | (nb, data) :: tl ->
+ (* some data to write *)
+ let len = String.length data in
+ let to_write = len - w.in_pos in
+ assert (len > 0 && to_write > 0) ;
+ if debug then log "%s cb: %d left in buffer" w.in_w.w_name to_write ;
+ if debug && w.in_pos = 0 then log "%s cb: writing '%s'" w.in_w.w_name (String.escaped data) ;
+
+ if List.mem `OUT conditions
+ then begin
+ let finished = do_write w data in
+ if finished
+ then begin
+ if debug then log "%s cb: finished writing cmd %d" w.in_w.w_name nb ;
+ (* written everything, proceed to the next chunk *)
+ w.in_data <- tl ;
+ w.in_pos <- 0
+ end
+ end
+ else
+ error_cb w.in_w conditions
+
+let _read_cb w conditions =
+ if debug then log "%s cb = %s" w.out_w.w_name (string_of_conditions conditions) ;
+ if List.mem `IN conditions
+ then begin
+ try
+ match Giochannel.read_chars w.out_w.w_chan w.out_sb with
+ | `NORMAL read ->
+ if debug then log "%s cb: read %d" w.out_w.w_name read ;
+ Buffer.add_substring w.out_buffer w.out_sb 0 read ;
+ w.out_cb w.out_buffer
+ | `EOF ->
+ if debug then log "%s cb: eof ?" w.out_w.w_name ;
+ w.out_w.exn_cb `FAILURE
+ | `AGAIN ->
+ if debug then log "%s cb: AGAIN" w.out_w.w_name
+ with exn ->
+ if debug then log "%s cb: error %s" w.out_w.w_name (Printexc.to_string exn) ;
+ w.out_w.exn_cb (`ERROR exn)
+ end
+ else
+ error_cb w.out_w conditions
+
+
+let reschedule_watch w =
+ match w.w_state with
+ | `WATCH _ -> true
+ | _ -> false
+
+let write_cb w c =
+ try _write_cb w c ; reschedule_watch w.in_w
+ with exn ->
+ if debug
+ then log "write cb %s: uncaught exception '%s'" w.in_w.w_name (Printexc.to_string exn) ;
+ true
+
+let read_cb w c =
+ try _read_cb w c ; reschedule_watch w.out_w
+ with exn ->
+ if debug
+ then log "read cb %s: uncaught exception '%s'" w.out_w.w_name (Printexc.to_string exn) ;
+ true
+
+
+let setup_watch_write w nb data =
+ match w.in_w.w_state with
+ | `DISABLED ->
+ assert (w.in_data = []) ;
+ w.in_data <- [ nb, data ] ;
+ w.in_pos <- 0 ;
+ let id = Giochannel.add_watch w.in_w.w_chan [ `OUT ; `HUP ; `ERR ] (write_cb w) in
+ w.in_w.w_state <- `WATCH id ;
+ | `WATCH _ ->
+ w.in_data <- w.in_data @ [ nb, data ]
+ | _ ->
+ assert (false)
+
+
+let setup_watch_read w =
+ assert (w.out_w.w_state = `DISABLED) ;
+ let id = Giochannel.add_watch w.out_w.w_chan [ `IN ; `HUP ; `ERR ] (read_cb w) in
+ w.out_w.w_state <- `WATCH id
+
+
+let setup_exn_cb w cb =
+ w.exn_cb <- cb w
+
+let setup_channel ~nonblock fd =
+ let chan = Giochannel.new_fd (some fd) in
+ if nonblock then Giochannel.set_flags_noerr chan [`NONBLOCK] ;
+ Giochannel.set_encoding chan None ;
+ Giochannel.set_buffered chan false ;
+ chan
+let make_watch name chan =
+ { w_name = name ; w_chan = chan ; w_state = `DISABLED ; exn_cb = ignore }
+let make_in_watch name fd =
+ let chan = setup_channel ~nonblock:true fd in
+ { in_w = make_watch name chan ; in_data = [] ; in_pos = 0 }
+let make_out_watch name fd =
+ let chan = setup_channel ~nonblock:false fd in
+ let w = {
+ out_w = make_watch name chan ;
+ out_sb = String.create 4096 ;
+ out_buffer = Buffer.create 1024 ;
+ out_cb = ignore
+ } in
+ setup_watch_read w ;
+ w
+
+
+
+
+
+
+
+
+let send_data p nb data =
+ if String.length data = 0
+ then invalid_arg "Automate.send_data: empty string" ;
+ setup_watch_write p.p_in nb data
+
+
+
+let encode_stdio cmd =
+ let b = Buffer.create 512 in
+ Buffer.add_char b 'l' ;
+ List.iter
+ (fun s -> Printf.bprintf b "%d:%s" (String.length s) s)
+ cmd ;
+ Buffer.add_string b "e\n" ;
+ Buffer.contents b
+
+
+
+let find_four_colon b =
+ let to_find = ref 4 in
+ let i = ref 0 in
+ while !to_find > 0 do
+ let c = Buffer.nth b !i in
+ if c = ':' then decr to_find ;
+ incr i
+ done ;
+ !i
+
+let truncate_buffer b off len =
+ let data = Buffer.sub b off len in
+ let rest = Buffer.sub b (off + len) (Buffer.length b - off - len) in
+ Buffer.clear b ;
+ Buffer.add_string b rest ;
+ data
+
+let decode_stdio_chunk b =
+ try
+ let header_len = find_four_colon b in
+ let h = Buffer.sub b 0 header_len in
+ let c1 = String.index_from h 0 ':' in
+ let number = int_of_string (string_slice ~e:c1 h) in
+ let code = int_of_char h.[c1 + 1] - int_of_char '0' in
+ let c2 = String.index_from h (c1 + 1) ':' in
+ let last = h.[c2 + 1] in
+ let c3 = String.index_from h (c2 + 1) ':' in
+ let c4 = String.index_from h (c3 + 1) ':' in
+ let len = int_of_string (string_slice ~s:(c3 + 1) ~e:c4 h) in
+ if Buffer.length b < header_len + len
+ then
+ `INCOMPLETE
+ else
+ let data = truncate_buffer b header_len len in
+ `CHUNK (number, code, last = 'l', data)
+ with Invalid_argument _ ->
+ `INCOMPLETE
+
+
+let aborted_cmd p nb =
+ not (List.mem_assoc nb p.callbacks)
+
+let rec out_cb p b =
+ match decode_stdio_chunk b with
+ | `INCOMPLETE ->
+ ()
+
+ | `CHUNK (nb, _, _, _) when aborted_cmd p nb ->
+ p.chunks <- List.remove_assoc nb p.chunks ;
+ out_cb p b
+
+ | `CHUNK ((nb, code, false, data) as chunk) ->
+ if debug then log "decoded a chunk" ;
+ let previous_chunks =
+ try List.assoc nb p.chunks
+ with Not_found ->
+ let c = ref [] in
+ p.chunks <- (nb, c) :: p.chunks ;
+ c in
+ previous_chunks := chunk :: !previous_chunks ;
+ out_cb p b
+
+ | `CHUNK ((nb, code, true, data) as chunk) ->
+ if debug then log "decoded last chunk" ;
+ let chunks =
+ try
+ let c = List.assoc nb p.chunks in
+ p.chunks <- List.remove_assoc nb p.chunks ;
+ List.rev (chunk :: !c)
+ with Not_found ->
+ [ chunk ] in
+ let cb = List.assoc nb p.callbacks in
+ p.callbacks <- List.remove_assoc nb p.callbacks ;
+ let msg =
+ String.concat ""
+ (List.map (fun (_, _, _, d) -> d) chunks) in
+ let data =
+ match code with
+ | 0 -> `OUTPUT msg
+ | 1 -> `SYNTAX_ERROR msg
+ | 2 -> `ERROR msg
+ | _ -> failwith "invalid_code in automate stdio output" in
+ ignore (Glib.Idle.add ~prio:0 (fun () -> cb data ; false)) ;
+ out_cb p b
+
+
+
+let check_exit p =
+ match p.state with
+ | `RUNNING
+ | `EXITING ->
+ ()
+ | `EXIT _ ->
+ let stderr = Buffer.contents p.p_err.out_buffer in
+ let r =
+ if p.p_in.in_w.w_state <> `HANGUP
+ then p.p_in.in_w.w_state
+ else if p.p_out.out_w.w_state <> `HANGUP
+ then p.p_out.out_w.w_state
+ else if p.p_err.out_w.w_state <> `HANGUP
+ then p.p_err.out_w.w_state
+ else `HANGUP in
+ match r with
+ | #pb as r -> p.exit_cb r stderr
+ | _ -> ()
+
+let exn_cb p w r =
+ if debug then log "%s exn_cb: %s" w.w_name (string_of_pb r) ;
+ if p.state = `RUNNING then p.state <- `EXITING ;
+ Giochannel.shutdown w.w_chan false ;
+ w.w_state <- (r : pb :> watch_state) ;
+ check_exit p
+
+let reap_cb p pid st =
+ if debug then log "reap_cb: %d" st ;
+ Gspawn.close_pid pid ;
+ if p.p_in.in_w.w_state = `DISABLED
+ then exn_cb p p.p_in.in_w `HANGUP ;
+ p.state <- `EXIT st ;
+ check_exit p
+
+
+
+
+let _submit p cmd cb =
+ Viz_misc.log "mtn" "sending command '%s'" (String.concat " " cmd) ;
+ let id = p.cmd_number in
+ send_data p id (encode_stdio cmd) ;
+ p.cmd_number <- id + 1 ;
+ p.callbacks <- (id, cb) :: p.callbacks ;
+ id
+
+
+let spawn mtn db =
+ let cmd = [ mtn ; "-d" ; db ; "automate" ; "stdio" ] in
+ if Viz_misc.debug "exec"
+ then Printf.eprintf "### exec: Running '%s'\n%!" (String.concat " " cmd) ;
+ let flags =
+ [ `PIPE_STDIN ; `PIPE_STDOUT ; `PIPE_STDERR ;
+ `SEARCH_PATH ; `DO_NOT_REAP_CHILD] in
+ let child = Gspawn.async_with_pipes ~flags cmd in
+ let p =
+ { p_in = make_in_watch "stdin" child.Gspawn.standard_input ;
+ p_out = make_out_watch "stdout" child.Gspawn.standard_output ;
+ p_err = make_out_watch "stderr" child.Gspawn.standard_error ;
+ state = `RUNNING ;
+ cmd_number = 0 ;
+ callbacks = [] ;
+ chunks = [] ;
+ exit_cb = (fun _ -> assert false)
+ } in
+ let pid = some child.Gspawn.pid in
+ ignore (Gspawn.add_child_watch ~prio:50 pid (reap_cb p pid)) ;
+ p.p_out.out_cb <- out_cb p ;
+ setup_exn_cb p.p_in.in_w (exn_cb p) ;
+ setup_exn_cb p.p_out.out_w (exn_cb p) ;
+ setup_exn_cb p.p_err.out_w (exn_cb p) ;
+ p
+
+
+
+
+
+let exit_cb ctrl p r stderr =
+ if debug then log "exit_cb: r='%s' stderr='%s'" (string_of_pb r) stderr ;
+ (* display dialog box in case of error ... *)
+ match ctrl.process with
+ | Some p' when p' == p ->
+ ctrl.process <- None ;
+ List.iter (fun (_, cb) -> cb (`ERROR stderr)) p.callbacks
+ | _ ->
+ ()
+
+
+let ensure_process ctrl =
+ match ctrl.process with
+ | Some ({ state = `RUNNING } as p) ->
+ p
+ | Some { state = `EXITING | `EXIT _ }
+ | None ->
+ let p = spawn ctrl.mtn ctrl.db_fname in
+ p.exit_cb <- exit_cb ctrl p ;
+ ctrl.process <- Some p ;
+ p
+
+
+
+
+
+
+
+
+
+let make mtn db = {
+ mtn = mtn ;
+ db_fname = db ;
+ process = None
+}
+
+let exit ctrl =
+ match ctrl.process with
+ | Some ({ state = `RUNNING } as p) ->
+ if debug then log "forced exit" ;
+ let w = p.p_in.in_w in
+ begin
+ match w.w_state with
+ | `WATCH id ->
+ Giochannel.remove_watch id
+ | _ -> ()
+ end ;
+ Giochannel.shutdown w.w_chan false ;
+ w.w_state <- `HANGUP
+ | Some { state = `EXITING | `EXIT _ }
+ | None ->
+ ()
+
+
+let submit ctrl cmd cb =
+ _submit (ensure_process ctrl) cmd cb
+
+let submit_sync ctrl cmd =
+ let output = ref None in
+ let exit_loop = ref false in
+ let _ =
+ submit
+ ctrl cmd
+ (fun v -> output := Some v ; exit_loop := true) in
+ while not !exit_loop do
+ ignore (Glib.Main.iteration true)
+ done ;
+ match some !output with
+ | `OUTPUT msg ->
+ msg
+ | `ERROR msg
+ | `SYNTAX_ERROR msg ->
+ Viz_types.errorf "mtn automate error: %s" msg
+
+
+
+let abort ctrl nb =
+ match ctrl.process with
+ | None ->
+ ()
+ | Some p ->
+ p.callbacks <- List.remove_assoc nb p.callbacks ;
+ match p.p_in.in_data with
+ | (id, _) :: tl when id = nb ->
+ if p.p_in.in_pos = 0
+ then begin
+ p.p_in.in_data <- tl ;
+ p.p_in.in_pos <- 0
+ end
+ | h :: tl ->
+ p.p_in.in_data <- h :: (List.remove_assoc nb tl)
+ | [] ->
+ ()
+
+
+(* TODO:
+ - add a timeout to exit the subprocess in case of inactivity
+ - add a submit_delayed to submit a cancellable command
+ with a small timeout (for keyboard nav)
+ - check exceptions and callbacks
+ - add asserts and sanity checks
+ *)
+
============================================================
--- automate.mli 27a0f822b26d9b436416f597c5a079f3f45bb784
+++ automate.mli 27a0f822b26d9b436416f597c5a079f3f45bb784
@@ -0,0 +1,19 @@
+
+type t
+type command_id = int
+type output = [
+ | `OUTPUT of string
+ | `ERROR of string
+ | `SYNTAX_ERROR of string]
+
+val get_info : t -> string * string
+val get_dbfname : t -> string
+
+val make : string -> string -> t
+val exit : t -> unit
+
+val submit : t -> string list -> (output -> unit) -> command_id
+val submit_sync : t -> string list -> string
+
+val abort : t -> command_id -> unit
+
============================================================
--- basic_io_lexer.mli 20d5687ac500fa12ef010d839f80d7a7f5d05aea
+++ basic_io_lexer.mli 20d5687ac500fa12ef010d839f80d7a7f5d05aea
@@ -0,0 +1,12 @@
+type v =
+ | ID of string
+ | STRING of string
+ | MULT of string list
+ | NONE
+type stanza = (string * v) list
+type t = stanza list
+
+val get_stanza : Lexing.lexbuf -> stanza option
+val parse : Lexing.lexbuf -> t
+
+val string_of_elem : v -> string
============================================================
--- basic_io_lexer.mll ba4720c3e3ad4457f5c75e1caf20cc562cda77f3
+++ basic_io_lexer.mll ba4720c3e3ad4457f5c75e1caf20cc562cda77f3
@@ -0,0 +1,109 @@
+{
+ type v =
+ | ID of string
+ | STRING of string
+ | MULT of string list
+ | NONE
+ type stanza = (string * v) list
+ type t = stanza list
+
+ let string_buffer =
+ Buffer.create 128
+
+ let rec make_value lex_value lb =
+ match lex_value lb with
+ | `NL -> NONE
+ | `STRING s ->
+ begin
+ match make_value lex_value lb with
+ | NONE ->
+ STRING s
+ | STRING s2 ->
+ MULT [ s ; s2 ]
+ | MULT sl ->
+ MULT (s :: sl)
+ | ID _ ->
+ failwith "Basic_io_lexer: value"
+ end
+ | `ID id ->
+ match lex_value lb with
+ | `NL -> ID id
+ | _ -> failwith "Basic_io_lexer: value"
+}
+
+let id = ['a'-'f' '0'-'9']*
+let ident = ['a'-'z' '_']+
+let ws = [' ' '\t']+
+let nl = [ '\n' ]
+
+rule lex = parse
+ | ws { lex lexbuf }
+ | ident as k { let v = make_value lex_value lexbuf in
+ `TOK (k, v) }
+ | nl { `END_OF_STANZA }
+ | eof { `EOF }
+
+and nl = parse
+ | ws { nl lexbuf }
+ | nl { () }
+
+and lex_value = parse
+ | ws { lex_value lexbuf }
+ | nl { `NL }
+ | '[' (id as id) ']' { `ID id }
+ | '"' { Buffer.clear string_buffer ;
+ `STRING (string lexbuf) }
+
+and string = parse
+ | '"' { Buffer.contents string_buffer }
+ | '\\' ['"' '\\'] { Buffer.add_char
+ string_buffer
+ (Lexing.lexeme_char lexbuf 1) ;
+ string lexbuf }
+ | [^ '"' '\\']+ { let off = lexbuf.Lexing.lex_start_pos in
+ let len = lexbuf.Lexing.lex_curr_pos - off in
+ Buffer.add_substring
+ string_buffer
+ lexbuf.Lexing.lex_buffer
+ off len ;
+ string lexbuf }
+
+{
+ let rec _get_stanza acc lb =
+ match lex lb with
+ | `TOK ((k, _) as v) ->
+ _get_stanza (v :: acc) lb
+ | `END_OF_STANZA when acc = [] ->
+ _get_stanza acc lb
+ | `EOF
+ | `END_OF_STANZA as e ->
+ e, List.rev acc
+
+ let get_stanza lb =
+ match _get_stanza [] lb with
+ | `EOF, [] ->
+ None
+ | _, st ->
+ Some st
+
+ let rec _parse acc lb =
+ match _get_stanza [] lb with
+ | `EOF, [] ->
+ List.rev acc
+ | `EOF, st ->
+ List.rev (st :: acc)
+ | `END_OF_STANZA, st ->
+ assert (st <> []) ;
+ _parse (st :: acc) lb
+
+ let parse lb =
+ _parse [] lb
+
+ let string_of_elem = function
+ | MULT (s :: _)
+ | STRING s
+ | ID s -> s
+ | MULT []
+ | NONE -> ""
+}
+
============================================================
--- monotone.ml 9fa93c28a72357c18adcafd38846c461a6be6845
+++ monotone.ml 9fa93c28a72357c18adcafd38846c461a6be6845
@@ -0,0 +1,398 @@
+open Viz_types
+
+type t = Automate.t
+
+let make = Automate.make
+let exit = Automate.exit
+
+let report_error cb fmt =
+ Printf.kprintf (fun s -> cb (`SUB_PROC_ERROR s)) fmt
+
+let spawn_monotone mtn cmd input status cb =
+ let mtn_exe, db_fname = Automate.get_info mtn in
+ let cmd = mtn_exe :: "--db" :: db_fname :: cmd in
+ try
+ status#push "Running monotone ..." ;
+ Subprocess.spawn
+ ~encoding:`NONE ~cmd ~input
+ ~reap_callback:status#pop
+ (fun ~exceptions ~stdout ~stderr status ->
+ if status = 0
+ then
+ cb (`OUTPUT stdout)
+ else if stderr = ""
+ then
+ report_error cb
+ "Monotone exited with status %d:\n%s"
+ status
+ (String.concat "\n" (List.map Printexc.to_string exceptions))
+ else
+ report_error cb
+ "Monotone error:\n%s"
+ stderr)
+ with Gspawn.Error (_, msg) ->
+ Viz_types.errorf "Could not execute monotone:\n%s" msg
+
+
+let run_monotone_diff mtn status cb (old_id, new_id) =
+ ignore (spawn_monotone
+ mtn
+ [ "--revision" ; old_id ;
+ "--revision" ; new_id ; "diff" ]
+ None status cb)
+
+
+
+let decode_count_branches d =
+ match Viz_misc.string_split '\n' d with
+ | _ :: l ->
+ let re = Str.regexp "\\([0-9]+\\) | \\(.*\\)" in
+ List.map
+ (fun r ->
+ if Str.string_match re r 0
+ then begin
+ let b = Str.matched_group 2 r
+ and n = Str.matched_group 1 r in
+ b, int_of_string n
+ end
+ else failwith "Monotone.decode_count_branches: bad format")
+ l
+ | _ ->
+ failwith "Monotone.decode_count_branches: bad format"
+
+let fake_status () =
+ object
+ method push _ = ()
+ method pop () = ()
+ end
+
+let wait_subproc mtn args =
+ let output = ref None
+ and exit_loop = ref false in
+ let cb v = output := Some v ; exit_loop := true in
+ ignore (spawn_monotone mtn args None (fake_status ()) cb) ;
+ while not !exit_loop do
+ ignore (Glib.Main.iteration true)
+ done ;
+ Viz_misc.some !output
+
+
+let run_monotone_count_branches mtn =
+ let counts =
+ let args = [ "db" ; "execute" ;
+ "SELECT COUNT(*), value FROM revision_certs WHERE name = 'branch' GROUP BY value" ] in
+ match wait_subproc mtn args with
+ | `SUB_PROC_ERROR _ -> []
+ | `OUTPUT d ->
+ try decode_count_branches d
+ with Failure _ -> [] in
+ match counts with
+ | [] -> fun b -> 0
+ | _ ->
+ let tbl = Viz_misc.hashtbl_of_list counts in
+ fun b -> try Hashtbl.find tbl b with Not_found -> 0
+
+
+
+
+
+
+
+let escape_selector s =
+ let len = String.length s in
+ let nb_escp = ref 0 in
+ for i = 0 to len - 1 do
+ let c = s.[i] in
+ if c = '\\' || c = '/'
+ then incr nb_escp
+ done ;
+ if !nb_escp = 0
+ then s
+ else begin
+ let o = String.create (len + !nb_escp) in
+ let j = ref 0 in
+ for i = 0 to len - 1 do
+ let c = s.[i] in
+ if c = '\\' || c = '/'
+ then (o.[!j] <- '\\' ; incr j) ;
+ o.[!j] <- c ;
+ incr j
+ done ;
+ assert (!j = len + !nb_escp) ;
+ o
+ end
+
+let ( +> ) x f = f x
+
+let decode_branches msg =
+ Viz_misc.string_split '\n' msg
+
+let branches mtn =
+ Automate.submit_sync
+ mtn
+ [ "branches" ]
+ +> decode_branches
+
+let node_data_of_revision rev_id certs (m_id, edges) =
+ { revision_id = rev_id ;
+ manifest_id = m_id ;
+ revision_set = List.map (fun e -> e.Revision.old_revision, e.Revision.change_set) edges ;
+ certs = certs ;
+ }
+
+let _get_revision mtn id certs =
+ Automate.submit_sync
+ mtn [ "get_revision" ; id ]
+ +> Lexing.from_string
+ +> Revision.revision_set
+ +> node_data_of_revision id certs
+
+let get_revision mtn id =
+ _get_revision mtn id []
+
+
+
+
+let get_elem st k =
+ try
+ Basic_io_lexer.string_of_elem
+ (List.assoc k st)
+ with Not_found -> "??"
+
+let sig_verif = function
+ | "ok" -> SIG_OK
+ | "bad" -> SIG_BAD
+ | "unknown" -> SIG_UNKNOWN
+ | _ -> failwith "Monotone.sig_verif"
+
+let cert_of_stanza id st =
+ { c_id = id ;
+ c_name = get_elem st "name" ;
+ c_value = get_elem st "value" ;
+ c_signer_id = get_elem st "key" ;
+ c_signature = sig_verif (get_elem st "signature") ;
+ }
+
+let raw_certs mtn id =
+ Automate.submit_sync
+ mtn [ "certs" ; id ]
+ +> Lexing.from_string
+ +> Basic_io_lexer.parse
+
+let certs mtn id =
+ raw_certs mtn id
+ +> List.map (cert_of_stanza id)
+
+let get_certs_and_revision mtn id =
+ certs mtn id
+ +> _get_revision mtn id
+
+let cert_value mtn id =
+ let c = raw_certs mtn id in
+ fun name ->
+ Viz_misc.list_filter_map
+ (fun st -> get_elem st "name" = name)
+ (fun st -> get_elem st "value")
+ c
+
+
+let select mtn selector =
+ Automate.submit_sync
+ mtn [ "select" ; selector ]
+ +> Viz_misc.string_split '\n'
+
+
+
+let selectors_of_query q =
+ match q.lim with
+ | QUERY_NO_LIMIT ->
+ List.map (fun b -> b, "b:" ^ escape_selector b) q.dom
+ | QUERY_BETWEEN (d1, d2) ->
+ let s_d =
+ match escape_selector d1, escape_selector d2 with
+ | "", "" -> []
+ | d1, "" -> [ "l:" ^ d1 ]
+ | "", d2 -> [ "e:" ^ d2 ]
+ | d1, d2 -> [ "l:" ^ d1 ; "e:" ^ d2 ] in
+ List.map
+ (fun b ->
+ let s_b = "b:" ^ escape_selector b in
+ let s_t = String.concat "/" (s_b :: s_d) in
+ b, s_t)
+ q.dom
+
+let get_ids mtn query =
+ List.fold_left
+ (fun set (b, s) ->
+ List.fold_left
+ (fun set id ->
+ try
+ let bl = NodeMap.find id set in
+ bl := b :: !bl ;
+ set
+ with Not_found ->
+ NodeMap.add id (ref [ b ]) set)
+ set
+ (select mtn s))
+ NodeMap.empty
+ (selectors_of_query query)
+
+let graph mtn =
+ Automate.submit_sync
+ mtn [ "graph" ]
+
+let children mtn id f init =
+ Automate.submit_sync mtn [ "children" ; id ]
+ +> Viz_misc.string_split '\n'
+ +> List.fold_left f init
+
+let decode_graph f init data =
+ let pos = ref 0 in
+ let acc = ref init in
+ begin
+ try
+ while true do
+ let e = String.index_from data !pos '\n' in
+ let nb = (e - !pos + 1) / 41 in (* len = 40 x k + k - 1 where k ∈ { 1, 2, 3 } *)
+ let id = String.sub data !pos 40 in
+ let p =
+ if nb <= 1 then
+ []
+ else if nb <= 2 then
+ [ String.sub data (!pos + 41) 40 ]
+ else
+ [ String.sub data (!pos + 41) 40 ; String.sub data (!pos + 82) 40 ] in
+ acc := f !acc id p ;
+ pos := e + 1
+ done
+ with Not_found -> ()
+ end ;
+ !acc
+
+let ensure_node agraph id kind family =
+ try
+ let n = NodeMap.find id agraph.nodes in
+ if n.kind < kind then n.kind <- kind ;
+ n.family <- family @ n.family ;
+ agraph
+ with Not_found ->
+ let n = { id = id ; kind = kind ; family = family } in
+ { agraph with nodes = NodeMap.add id n agraph.nodes }
+
+let edge_kind b_set i1 i2 =
+ try
+ let b1 = NodeMap.find i1 b_set in
+ let b2 = NodeMap.find i2 b_set in
+ if List.exists (fun b -> List.mem b !b1) !b2
+ then SAME_BRANCH
+ else BRANCHING
+ with Not_found ->
+ BRANCHING_NEIGH
+
+let ensure_edge agraph b_set i1 i2 =
+ let e = edge_kind b_set i1 i2 in
+ { agraph with ancestry = EdgeMap.add (i1, i2) e agraph.ancestry }
+
+let interesting_node id_set id =
+ id_set = NodeMap.empty || NodeMap.mem id id_set
+
+let only_one_child mtn id =
+ children mtn id (fun n _ -> n + 1) 0 <= 1
+
+let keep_neighbor_out mtn all_propagates p p_in_graph =
+ all_propagates
+ || List.length p_in_graph = List.length p
+ || List.for_all (only_one_child mtn) p_in_graph
+
+let add_node mtn query ids agraph id p =
+ if interesting_node ids id
+ then begin
+ let agraph =
+ ensure_node agraph id
+ (if List.length p >= 2 then MERGE else REGULAR)
+ (List.map (fun i -> i, PARENT) p) in
+ let p =
+ List.map (fun id_p -> id_p, interesting_node ids id_p) p in
+ List.fold_left
+ (fun agraph (id_p, is_reg) ->
+ let agraph =
+ ensure_node agraph id_p
+ (if is_reg then REGULAR else NEIGHBOUR_IN)
+ [ id, CHILD ] in
+ ensure_edge agraph ids id_p id)
+ agraph p
+ end
+ else
+ match List.filter (interesting_node ids) p with
+ | [] ->
+ agraph
+ | p_in_graph when keep_neighbor_out mtn query.all_propagates p p_in_graph ->
+ let agraph =
+ ensure_node agraph id
+ NEIGHBOUR_OUT
+ (List.map (fun i -> i, PARENT) p_in_graph) in
+ List.fold_left
+ (fun agraph id_p ->
+ let agraph =
+ ensure_node agraph id_p
+ REGULAR [ id, CHILD ] in
+ ensure_edge agraph ids id_p id)
+ agraph p_in_graph
+ | _ ->
+ agraph
+
+let grab_tags mtn agraph =
+ Automate.submit_sync mtn [ "tags" ]
+ +> Lexing.from_string
+ +> Basic_io_lexer.parse
+ +> List.fold_left (fun agraph st ->
+ try
+ let n = NodeMap.find (get_elem st "revision") agraph.nodes in
+ n.kind <- TAGGED (get_elem st "tag") ;
+ agraph
+ with Not_found -> agraph)
+ agraph
+
+let agraph mtn query =
+ let ids = get_ids mtn query in
+ graph mtn
+ +> decode_graph (add_node mtn query ids) empty_agraph
+ +> grab_tags mtn
+ +> Components.reconnect (children mtn)
+
+(* TODO:
+ - distinguish between true neighbor nodes and nodes that are outside the date limit.
+ *)
+
+
+let join nb cb =
+ let cnt = ref nb in
+ let acc = ref [] in
+ function
+ | `OUTPUT data when !cnt = 1 ->
+ let total = List.rev (data :: !acc) in
+ cb (`OUTPUT total)
+ | `OUTPUT data ->
+ acc := data :: !acc ;
+ decr cnt
+ | `ERROR msg
+ | `SYNTAX_ERROR msg ->
+ cnt := 0 ;
+ cb (`SUB_PROC_ERROR msg)
+
+let decode cb = function
+ | `SUB_PROC_ERROR _ as r ->
+ cb r
+ | `OUTPUT d ->
+ let ids = List.flatten (List.map (Viz_misc.string_split '\n') d) in
+ cb (`IDS ids)
+
+let select_async mtn cb selectors =
+ let nb_selectors =
+ List.length selectors in
+ let auto_cb = join nb_selectors (decode cb) in
+ List.map
+ (fun sel -> Automate.submit mtn [ "select" ; sel ] auto_cb)
+ selectors
+
+
============================================================
--- monotone.mli a629c1ce8cc72db8296bc3dc8433f1f2ce8ead9e
+++ monotone.mli a629c1ce8cc72db8296bc3dc8433f1f2ce8ead9e
@@ -0,0 +1,27 @@
+
+type t = Automate.t
+
+val make : string -> string -> t
+val exit : t -> unit
+
+val run_monotone_diff :
+ t ->
+ <push : string -> unit; pop : unit -> unit; ..> ->
+ ([>`SUB_PROC_ERROR of string | `OUTPUT of string] -> unit) ->
+ string * string -> unit
+
+val run_monotone_count_branches : t -> (string -> int)
+
+val escape_selector : string -> string
+
+val branches : t -> string list
+val get_revision : t -> string -> Viz_types.node_data
+val get_certs_and_revision : t -> string -> Viz_types.node_data
+val cert_value : t -> string -> string -> string list
+val select : t -> string -> string list
+val agraph : t -> Viz_types.query -> Viz_types.agraph
+
+val select_async :
+ t ->
+ ([>`SUB_PROC_ERROR of string | `IDS of string list] -> unit) ->
+ string list -> Automate.command_id list
============================================================
--- revision.ml ed65760918027461605d1691fd2fc6f50e63cc47
+++ revision.ml ed65760918027461605d1691fd2fc6f50e63cc47
@@ -0,0 +1,91 @@
+
+type change =
+ | DELETE of string
+ | RENAME of string * string
+ | ADD_DIR of string
+ | ADD_FILE of string * string
+ | PATCH of string * string * string
+ | ATTR_CLEAR of string * string
+ | ATTR_SET of string * string * string
+
+type edge = {
+ old_revision : string ;
+ change_set : change list ;
+ }
+
+type t = string * edge list
+
+
+type tok = Basic_io_lexer.v =
+ | ID of string
+ | STRING of string
+ | MULT of string list
+ | NONE
+
+
+let rec _star acc p = parser
+ | [< v = p ; nxt >] -> _star (v :: acc) p nxt
+ | [<>] -> acc
+
+
+let format = parser
+ | [< ' [ "format_version", STRING "1" ] >] ->
+ ()
+let new_manifest = parser
+ | [< ' [ "new_manifest", ID id ] >] ->
+ id
+
+let delete = parser
+ | [< ' [ "delete", STRING p ] >] ->
+ DELETE p
+let rename = parser
+ | [< ' [ "rename", STRING p ;
+ "to", STRING np ] >] ->
+ RENAME (p, np)
+let add_dir = parser
+ | [< ' [ "add_dir", STRING p ] >] ->
+ ADD_DIR p
+let add_file = parser
+ | [< ' [ "add_file", STRING p ;
+ "content", ID id ] >] ->
+ ADD_FILE (p, id)
+let patch = parser
+ | [< ' [ "patch", STRING p ;
+ "from", ID id1 ;
+ "to", ID id2 ] >] ->
+ PATCH (p, id1, id2)
+let clear = parser
+ | [< ' [ "clear", STRING p ;
+ "attr", STRING a ] >] ->
+ ATTR_CLEAR (p, a)
+let set = parser
+ | [< ' [ "set", STRING p ;
+ "attr", STRING a ;
+ "value", STRING v ] >] ->
+ ATTR_SET (p, a, v)
+let change_set = parser
+ | [< cs = _star [] delete ;
+ cs = _star cs rename ;
+ cs = _star cs add_dir ;
+ cs = _star cs add_file ;
+ cs = _star cs patch ;
+ cs = _star cs clear ;
+ cs = _star cs set >] -> List.rev cs
+
+let edge = parser
+ | [< ' [ "old_revision", ID id ] ; cs = change_set >] ->
+ { old_revision = id ; change_set = cs }
+
+
+let revision = parser
+ | [< () = format ;
+ manifest = new_manifest ;
+ edges = _star [] edge >] ->
+ manifest, List.rev edges
+
+
+let revision_set lb =
+ let strm =
+ Stream.from
+ (fun _ -> Basic_io_lexer.get_stanza lb) in
+ revision strm
============================================================
--- revision.mli c55251affdd8ab000599767b9e473cab8ad23b0b
+++ revision.mli c55251affdd8ab000599767b9e473cab8ad23b0b
@@ -0,0 +1,17 @@
+type change =
+ | DELETE of string
+ | RENAME of string * string
+ | ADD_DIR of string
+ | ADD_FILE of string * string
+ | PATCH of string * string * string
+ | ATTR_CLEAR of string * string
+ | ATTR_SET of string * string * string
+
+type edge = {
+ old_revision : string ;
+ change_set : change list ;
+ }
+
+type t = string * edge list
+
+val revision_set : Lexing.lexbuf -> t
============================================================
--- INSTALL 656dd842a340729b89f5d42611d01db59800d7ef
+++ INSTALL e80e9f3656f902f59c2adb63b6ce5c09ff165a55
@@ -13,13 +13,11 @@ compile from source, something like this
$ make install
-* GTK+, libgnomecanvas & OpenSSL's libcrypto
-You'll need the development packages of GTK+ 2.4 (or newer) and
-libgnomecanvas. You'll also need OpenSSL's development package
-(monotone-viz uses libcrypto).
+* GTK+, libgnomecanvas
+You'll need the development packages of GTK+ 2.6 (or newer) and
+libgnomecanvas.
-
* LablGTK
LablGTK is a GTK+ bindings for ocaml [2].
Tarballs distributions of monotone-viz include LablGTK so you don't have
@@ -28,7 +26,7 @@ make sure you have a version more recent
If you pulled monotone-viz from the monotone repository, you need a
compiled LablGTK. It is packaged for some Linux distributions, but
make sure you have a version more recent than 2.4.0. The latest
-version is lablgtk2-20050701. 2.4.0 will *not* work. If you're
+version is lablgtk2-2.10.0. lablgtk-2.4.0 will *not* work. If you're
compiling LablGTK from source, make sure LablGTK is built with
libgnomecanvas support:
@@ -37,19 +35,6 @@ libgnomecanvas support:
$ make install
-* Sqlite
-Monotone-viz can either use the sqlite3 library that is statically
-linked into the monotone executable, or a shared sqlite3 library. The
-former is safer (monotone-viz runs the same code as monotone to access
-the database) but you need to have a compiled monotone tree. The
-shared library build is the default.
-
-If you want to use the static sqlite3 library, create a link named
-monotone to the monotone build tree and run configure:
-
- $ ln -s /path/to/monotone-tree monotone
- $ ./configure --with-shared-sqlite=no
-
* Monotone-viz
Compiling monotone-viz should now be as simple as:
============================================================
--- Makefile 959a7ff9f2703b28fd79c4a0fbb073ed1d27f353
+++ Makefile e2382b7c2e004fd4b9c59eb1035f191ffdc5c1a3
@@ -1,39 +1,31 @@ include config.make
include config.make
-OCAMLNET := ocamlnet-0.97.1
-EXTLIB := extlib-1.3
-
-MLINCDIRS_LOCAL = -I $(OCAMLNET) -I mlsqlite -I $(EXTLIB) -I glib -I crypto
+MLINCDIRS_LOCAL = -I glib
MLINCDIRS = -I $(LABLGTK_DIR) $(MLINCDIRS_LOCAL)
-GTK_CFLAGS := $(shell pkg-config gtk+-2.0 --cflags)
-GNOMECANVAS_CFLAGS := $(shell pkg-config libgnomecanvas-2.0 --cflags)
+GTK_CFLAGS := $(shell pkg-config gtk+-2.0 --cflags)
+GNOMECANVAS_CFLAGS := $(shell pkg-config libgnomecanvas-2.0 pangoft2 --cflags)
-SRC = $(OCAMLNET)/base64.ml $(OCAMLNET)/base64.mli \
- mlsqlite/sqlite3.ml mlsqlite/sqlite3.mli \
- $(EXTLIB)/IO.mli $(EXTLIB)/IO.ml $(EXTLIB)/unzip.ml $(EXTLIB)/unzip.mli \
- glib/gspawn.ml glib/gspawn.mli glib/giochannel.ml glib/giochannel.mli \
+SRC = glib/gspawn.ml glib/gspawn.mli glib/giochannel.ml glib/giochannel.mli \
glib/viz_gmisc.ml glib/gpattern.ml \
- crypto/crypto.ml crypto/crypto.mli \
viz_misc.ml viz_misc.mli viz_types.ml viz_types.mli \
q.ml q.mli \
dot_lexer.ml dot_parser.ml dot_parser.mli \
- revision_types.mli revision_lexer.ml revision_parser.ml revision_parser.mli \
+ basic_io_lexer.mli basic_io_lexer.ml revision.mli revision.ml \
subprocess.ml subprocess.mli \
- components.ml schema_lexer.ml \
- database.ml database.mli agraph.ml agraph.mli \
+ components.ml \
+ automate.mli automate.ml monotone.mli monotone.ml \
+ agraph.ml agraph.mli \
autocolor.ml autocolor.mli viz_style.ml viz_style.mli \
- icon.ml ui.ml ui.mli unidiff.ml unidiff.mli \
- view.ml view.mli query.ml query.mli app.ml app.mli version.ml main.ml
+ version.ml icon.ml ui.ml ui.mli unidiff.ml unidiff.mli \
+ view.ml view.mli query.ml query.mli app.ml app.mli main.ml
-C_OBJ = mlsqlite/ocaml-sqlite3.o \
- glib/ocaml-gspawn.o glib/ocaml-giochannel.o \
+C_OBJ = glib/ocaml-gspawn.o glib/ocaml-giochannel.o \
glib/ocaml-misc.o glib/ocaml-gdate.o glib/ocaml-gpattern.o \
- crypto/ocaml-openssl.o \
gnomecanvas_hack.o
-USE_P4 = viz_style.ml
+USE_P4 = viz_style.ml revision.ml
OBJ = $(patsubst %.ml,%.cmo,$(filter %.ml, $(SRC)))
OBJX = $(patsubst %.ml,%.cmx,$(filter %.ml, $(SRC)))
@@ -44,20 +36,15 @@ DISTSRC = Makefile configure.ac config.m
autocolor.ml autocolor.mli viz_style.ml viz_style.mli \
dot_types.mli dot_lexer.mll dot_parser.mly \
subprocess.ml subprocess.mli icon.ml ui.ml ui.mli \
- revision_types.mli revision_lexer.mll revision_parser.mly \
- components.ml schema_lexer.mll database.ml database.mli agraph.ml agraph.mli \
+ basic_io_lexer.mll basic_io_lexer.mli revision.mli revision.ml \
+ components.ml automate.mli automate.ml monotone.mli monotone.ml agraph.ml agraph.mli \
unidiff.ml unidiff.mli gnomecanvas_hack.c view.ml view.mli \
query.ml query.mli app.mli app.ml main.ml \
- mlsqlite/sqlite3.ml mlsqlite/sqlite3.mli \
- mlsqlite/config.h mlsqlite/ocaml-sqlite3.h mlsqlite/ocaml-sqlite3.c \
- ocamlnet-0.97.1/base64.ml ocamlnet-0.97.1/base64.mli ocamlnet-0.97.1/LICENSE \
- extlib-1.3/IO.ml extlib-1.3/IO.mli extlib-1.3/unzip.ml extlib-1.3/unzip.mli \
glib/gspawn.ml glib/gspawn.mli glib/giochannel.ml glib/giochannel.mli \
glib/viz_gmisc.ml glib/gpattern.ml \
glib/ocaml-gspawn.c glib/ocaml-giochannel.c \
glib/ocaml-misc.c glib/ocaml-gdate.c glib/ocaml-gpattern.c \
- glib/gspawn_tags.var glib/giochannel_tags.var \
- crypto/ocaml-openssl.c crypto/crypto.ml crypto/crypto.mli
+ glib/gspawn_tags.var glib/giochannel_tags.var
DIST_LABLGTK= lablgtk/configure lablgtk/configure.in lablgtk/config.make.in \
lablgtk/COPYING lablgtk/CHANGES lablgtk/README* \
lablgtk/Makefile lablgtk/src/Makefile lablgtk/src/.depend \
@@ -66,23 +53,18 @@ DIST_LABLGTK= lablgtk/configure lablgtk/
-ifdef SQLITE_LIBS
LIB3RDPARTY_OBJ = $(C_OBJ)
-SQLITE_LINK = -cclib "$(SQLITE_LIBS)"
-else
-LIB3RDPARTY_OBJ = $(MONOTONE_DIR)/sqlite/lib3rdparty_a-*.o $(C_OBJ)
-endif
ifeq ($(OCAMLBEST), opt)
monotone-viz : $(OBJX) lib3rdparty.a
- $(OCAMLOPT) -o $@ -I $(LABLGTK_DIR) $(MLLIBS) $^ $(CRYPTO_LIB) $(SQLITE_LINK)
+ $(OCAMLOPT) -o $@ -I $(LABLGTK_DIR) $(MLLIBS) $^
monotone-viz : MLLIBS = str.cmxa lablgtk.cmxa gtkInit.cmx lablgnomecanvas.cmxa
ifeq ($(LOCAL_LABLGTK), yes)
$(OBJX) : .lablgtk
endif
else
monotone-viz : $(OBJ) lib3rdparty.a
- $(OCAMLC) -custom -o $@ -I $(LABLGTK_DIR) $(MLLIBS) $^ $(CRYPTO_LIB) $(SQLITE_LINK)
+ $(OCAMLC) -custom -o $@ -I $(LABLGTK_DIR) $(MLLIBS) $^
monotone-viz : MLLIBS = str.cma lablgtk.cma gtkInit.cmo lablgnomecanvas.cma
ifeq ($(LOCAL_LABLGTK), yes)
$(OBJ) : .lablgtk
@@ -95,17 +77,10 @@ glib/ocaml-%.o : CINCDIRS = -I
glib/ocaml-gspawn.o : glib/gspawn_tags.c glib/gspawn_tags.h
glib/ocaml-giochannel.o : glib/giochannel_tags.c glib/giochannel_tags.h
glib/ocaml-%.o : CINCDIRS = -I $(LABLGTK_DIR) -ccopt "$(GTK_CFLAGS)"
-ifdef SQLITE_LIBS
-mlsqlite/ocaml-sqlite3.o : CINCDIRS = -ccopt "$(SQLITE_CFLAGS)"
-else
-mlsqlite/ocaml-sqlite3.o : CINCDIRS = -I $(MONOTONE_DIR)/sqlite
-endif
-crypto/ocaml-openssl.o : CINCDIRS = -ccopt "$(CRYPTO_CFLAGS)"
gnomecanvas_hack.o : CINCDIRS = -ccopt "$(GNOMECANVAS_CFLAGS)"
-$(EXTLIB)/unzip.% : MLFLAGS += -w y
REVISION_FILE := $(shell test -r _MTN/revision && echo _MTN/revision)
-REVISION_ID = $(shell mtn automate get_base_revision_id || ( test -r _MTN/revision && ( if grep format_version _MTN/revision > /dev/null; then grep old_revision _MTN/revision | sed -e 's/^old_revision \[//' -e 's/\] *$$//'; else cat _MTN/revision; fi )))
+REVISION_ID = $(shell mtn automate get_base_revision_id)
version.ml : version.ml.in $(REVISION_FILE)
sed -e 's/@REVISION@/$(REVISION_ID)/' -e 's/@VERSION@/$(VERSION)/' < $< > $@
@@ -134,14 +109,8 @@ clean :
clean :
rm -f *.a *.so *.o *.cm* monotone-viz
- rm -f dot_lexer.ml dot_parser.ml dot_parser.mli
- rm -f revision_lexer.ml revision_parser.ml revision_parser.mli
- rm -f schema_lexer.ml
- cd mlsqlite && rm -f *.a *.so *.o *.cm*
- cd $(OCAMLNET) && rm -f *.o *.cm*
- cd $(EXTLIB) && rm -f *.o *.cm*
+ rm -f dot_lexer.ml dot_parser.ml dot_parser.mli basic_io_lexer.ml
cd glib && rm -f *.o *.cm*
- cd crypto && rm -f *.o *.cm*
install :
install -d $(DESTDIR)$(bindir)
============================================================
--- NEWS e5dc9e771afb20d9d025ddd0cd85be9ec3d6dcba
+++ NEWS 71057e70a09a20c4d356f18b3e19f197c3c46bcd
@@ -1,3 +1,12 @@
+1.0.1:
+- fix a compilation problem on some systems
+- be more precise concerning the license (GPL 2+)
+
+1.0:
+- do not access the monotone database directly: obtain all necessay
+ information via the "mtn automate" mechanism
+- add an "About" dialog
+
0.15:
- adapt to newer monotone versions (new name of the program,
new book-keeping directory format)
============================================================
--- README ca8f7f128d188deaecc95d31dc580154e53fd454
+++ README 7df1a7e44da44166e93bc4d1a627c19082634036
@@ -5,17 +5,15 @@
This is a small GNOME application to visualize monotone ancestry
graphs.
-Monotone-viz is licensed under the GPL (General Public License,
-version 2).
+Monotone-viz is licensed under the GPL (General Public License),
+either version 2, or (at your option) any later version.
REQUIREMENTS
============
- dot from the graphviz package
http://www.research.att.com/sw/tools/graphviz/
-- GTK+ 2.4, libgnomecanvas
-- OpenSSL development files
-- either a compiled monotone tree or sqlite development files
+- GTK+ >= 2.6, libgnomecanvas
COMPILING
@@ -27,8 +25,6 @@
- run ./configure, with the following options if needed:
--with-lablgtk-dir=
--without-local-lablgtk
- --with-monotone-dir=
- --without-shared-sqlite
--bindir
- make
- make install
@@ -77,5 +73,5 @@
--
-Olivier Andrieu <oandrieu@nerim.net>
+Olivier Andrieu <oandrieu@gmail.com>
http://oandrieu.nerim.net/monotone-viz/
============================================================
--- agraph.ml 5823b36800b8a29b8a9b1105ee4945620526da33
+++ agraph.ml 8ae6c9bb70bbf9fd80e4e62d9f162ac581619b9e
@@ -227,8 +227,6 @@ let spawn_dot graph status done_cb =
"set -o pipefail ; \
tee agraph.in.dot | %s -q -y -s%.0f | tee agraph.out.dot" dot_prg ppi ]
else [ dot_prg ; "-q" ; "-y" ; Printf.sprintf "-s%.0f" ppi ] in
- if Viz_misc.debug "exec"
- then Printf.eprintf "### exec: Running '%s'\n%!" (String.concat " " cmd) ;
let error fmt =
Printf.kprintf (fun s -> done_cb (`LAYOUT_ERROR s)) fmt in
try
============================================================
--- app.ml ecdd153474516d486e2ad04862b65f537522a10e
+++ app.ml e62a81510dee75756f4a3db537240560d5ffa1b0
@@ -10,7 +10,7 @@ class type t =
class type t =
object
- method get_db : Database.t option
+ method get_mtn : Monotone.t option
method get_agraph : Agraph.t option
method get_prefs : Viz_style.prefs
method get_toplevel : GWindow.window
@@ -56,7 +56,7 @@ class ctrl w ~prefs ~manager ~status ~vi
class ctrl w ~prefs ~manager ~status ~view : t =
let busy = Ui.Busy.make w in
object (self)
- val mutable db = None
+ val mutable mtn = None
val mutable agraph = None
val mutable prefs = prefs
val mutable query = None
@@ -78,7 +78,7 @@ class ctrl w ~prefs ~manager ~status ~vi
open_d <- Some d ;
d
- method get_db = db
+ method get_mtn = mtn
method get_agraph = agraph
method get_prefs = prefs
@@ -89,13 +89,10 @@ class ctrl w ~prefs ~manager ~status ~vi
prefs <- new_prefs ;
Ui.Prefs.update_prefs self old_prefs new_prefs
- method private locked_db _ =
- Ui.LockedDB.show self
-
method open_db ?id ?branch fname =
self#close_db () ;
- let m_db = Database.open_db ~busy_handler:self#locked_db fname in
- db <- Some m_db ;
+ let m_mtn = Monotone.make prefs.Viz_style.monotone_path fname in
+ mtn <- Some m_mtn ;
View.open_db view self ;
Ui.open_db manager self ;
match branch with
@@ -108,15 +105,15 @@ class ctrl w ~prefs ~manager ~status ~vi
method close_db () =
self#clear ;
- may Database.close_db db ;
- db <- None ;
+ may Monotone.exit mtn ;
+ mtn <- None ;
may Agraph.abort_layout agraph ;
agraph <- None ;
View.close_db view self ;
Ui.close_db manager self
method finalize () =
- may Database.close_db db
+ may Monotone.exit mtn
method display_certs id =
Ui.Busy.start busy ;
@@ -133,7 +130,7 @@ class ctrl w ~prefs ~manager ~status ~vi
method reload () =
let s = view.View.selector in
- let fname = maybe Database.get_filename db in
+ let fname = maybe Automate.get_dbfname mtn in
let id = self#get_selected_node in
let state = View.Branch_selector.get_state s in
self#close_db () ;
@@ -169,15 +166,14 @@ class ctrl w ~prefs ~manager ~status ~vi
agraph <- None ;
self#clear ;
may
- (fun db ->
+ (fun mtn ->
Ui.Busy.start busy ;
let g1 =
(self#status "agraph")#with_status
"Building ancestry graph"
(fun () ->
- Ui.nice_fetch
- (fun db -> Database.fetch_ancestry_graph db query.Viz_types.query)
- db) in
+ Ui.with_grab
+ (fun () -> Monotone.agraph mtn query.Viz_types.query)) in
let g2 =
Agraph.make
g1
@@ -193,7 +189,7 @@ class ctrl w ~prefs ~manager ~status ~vi
view self
query.Viz_types.preselect) in
agraph <- Some g2)
- db
+ mtn
method private layout_params =
let (w, h, cw) = View.Canvas.id_size view.View.canvas self in
============================================================
--- app.mli 221b1797f90548892501681a900a80ee017d9359
+++ app.mli 81de698901b6c3e71f1b3ef78377748697b32294
@@ -10,7 +10,7 @@ class type t =
class type t =
object
- method get_db : Database.t option
+ method get_mtn : Monotone.t option
method get_agraph : Agraph.t option
method get_prefs : Viz_style.prefs
method get_toplevel : GWindow.window
============================================================
--- autocolor.ml 9d59f87e56d79aad8c632cff38b12fab557814df
+++ autocolor.ml 940507d413a192f50208ca5723b2c99749dac513
@@ -28,7 +28,7 @@ let autocolor_hash s =
0xffl
let autocolor_hash s =
- let hash = Crypto.sha1 s in
+ let hash = Digest.string s in
let f_of_hash p = float (Char.code hash.[p]) /. 256. in
(* take 8 bits for hue *)
let hue = f_of_hash 0 in
@@ -44,42 +44,14 @@ let autocolor_hash s =
s hue li sat r g b ;
rgba_color triplet
-let quasi_random n =
- let v = ref (float n) in
- for i = 1 to 8 do
- let d = float (n lsr i) /. float (1 lsl i) in
- if i mod 2 = 1
- then v := !v -. d
- else v := !v +. d
- done ;
- fst (modf (!v /. 2.))
-
-let hex = [| 0.; 1./.3.; 2./.3.; 1./.6.; 3./.6.; 5./.6. |]
-let quasi_random_hue n =
- let displ = quasi_random (n / 6) in
- hex.(n mod 6) +. displ /. 6.
-
let white = 0xffffffffl
-let autocolor_quasi_random db s =
- try
- let id = Database.get_key_rowid db s in
- let hue = quasi_random_hue id in
- let (r, g, b) as triplet = hls_to_rgb hue 0.75 0.75 in
- if Viz_misc.debug "color"
- then Printf.eprintf
- "autocolor (%30s) = id=%2d H=%.2f R=%3d G=%3d B=%3d\n%!" s id hue r g b ;
- rgba_color triplet
- with Not_found ->
- white
-
-let autocolor kind db =
+let autocolor kind =
let lookup_autocolor =
Viz_misc.make_cache
begin
match kind with
| NONE -> (fun id -> white)
- | BY_KEYID -> autocolor_quasi_random db
| BY_AUTHOR_HASH -> autocolor_hash
| BY_BRANCH_HASH -> autocolor_hash
end in
============================================================
--- autocolor.mli 6380f588de9f3457c50c7d20846b6cc6a0d0efa9
+++ autocolor.mli c8ade8687ec54d7852d55545e08f92b884f08120
@@ -1,3 +1,3 @@
-val autocolor : Viz_types.autocolor -> Database.t -> (string list -> int32)
+val autocolor : Viz_types.autocolor -> (string list -> int32)
============================================================
--- config.make.in 93dc881513748f3dad53927c5e1f021129d40a6c
+++ config.make.in ab4dd391e36577ee261132a3e330476f043cc551
@@ -15,10 +15,6 @@ endif
LABLGTK_DIR := @LABLGTK_DIR@
endif
-MONOTONE_DIR := @MONOTONE_DIR@
-CRYPTO_LIB := @CRYPTO_LIB@
-SQLITE_CFLAGS := @SQLITE_CFLAGS@
-SQLITE_LIBS := @SQLITE_LIBS@
CPPFLAGS := @CPPFLAGS@
prefix := @prefix@
============================================================
--- configure.ac 7099114251fbf1712393a6ec463554fb3edb63df
+++ configure.ac 28cc3999f3e5277dea5b79dfc04c1f8396c3af9d
@@ -1,4 +1,4 @@
-AC_INIT(monotone-viz, 0.15)
+AC_INIT(monotone-viz, 1.0.1)
AC_PROG_OCAML
AC_PROG_OCAML_TOOLS
@@ -86,53 +86,6 @@ fi
echo
fi
-# Check the sqlite3 sources
-AC_ARG_WITH([monotone-dir],
- AS_HELP_STRING([--with-monotone-dir=],
- [specify location of monotone build tree]),
- MONOTONE_DIR=$withval,
- MONOTONE_DIR=monotone)
-AC_ARG_WITH([shared-sqlite],
- AS_HELP_STRING([--without-shared-sqlite],
- [use a system-wide shared sqlite library]),
- SHARED_SQLITE=$withval,
- SHARED_SQLITE=maybe)
-if test "$SHARED_SQLITE" = "yes" -o '(' "$SHARED_SQLITE" = "maybe" -a ! -d "$MONOTONE_DIR" ')' ; then
- # Actually we need at least 3.2.2 but the micro number isn't in the
- # pkgconfig file (sigh)
- PKG_CHECK_MODULES(SQLITE, sqlite3 >= 3.2,
- SHARED_SQLITE=yes,
- if test "$SHARED_SQLITE" = "yes" ; then AC_MSG_ERROR([
-Couldn't find the shared sqlite package.]) ; fi)
-fi
-
-if test "$SHARED_SQLITE" != "yes" ; then
- AC_MSG_CHECKING(monotone's sqlite)
- if test -d "$MONOTONE_DIR" -a -r "$MONOTONE_DIR/sqlite/lib3rdparty_a-main.o" ; then
- AC_MSG_RESULT(found in $MONOTONE_DIR/sqlite)
- else
- AC_MSG_ERROR([
-
-Could not find compiled sqlite sources. Monotone-viz needs a compiled
-monotone tree for the sqlite library. Create a link named `monotone'
-or specify the location to configure using the `--with-monotone-dir='
-option.])
- fi
- if test "${MONOTONE_DIR:0:1}" != "/" ; then
- MONOTONE_DIR="$(pwd)/$MONOTONE_DIR"
- fi
-fi
-AC_SUBST(MONOTONE_DIR)
-
-
-# Check for libcrypto using pkg-config, defaulting to /usr/lib
-AC_MSG_CHECKING(OpenSSL's crypto lib)
-CRYPTO_LIB_DIR="$(pkg-config openssl --variable=libdir)"
-CRYPTO_LIB="${CRYPTO_LIB_DIR:-/usr/lib}/libcrypto.a"
-AC_MSG_RESULT($CRYPTO_LIB)
-AC_SUBST(CRYPTO_LIB)
-
-
# Keep CPPFLAGS around, can be useful if caml headers are in a
# non-standard location.
AC_SUBST(CPPFLAGS)
============================================================
--- dot_lexer.mll 3a71fb27288b4d3e0c3162a24153e34d89358d4f
+++ dot_lexer.mll a466db6a992849b3408646516d0d8936ce334a43
@@ -14,13 +14,14 @@
"subgraph", SUBGRAPH; ]
}
+let ws = [' ' '\t' '\n' '\r']
let alpha = ['A'-'Z' 'a'-'z']
let digit = ['0'-'9']
let ident = (alpha | '_') (alpha | '_' | digit)*
let number = digit+
rule lex = parse
- | [ ' ' '\n' '\t']+ { lex lexbuf }
+ | ws+ { lex lexbuf }
| '#' [^ '\n']* '\n' { lex lexbuf }
| "//" [^ '\n']* '\n' { lex lexbuf }
| "/*" { comment lexbuf ; lex lexbuf }
@@ -48,7 +49,8 @@ and string b = parse
and string b = parse
| '"' { () }
- | "\\\n" { string b lexbuf }
+ | '\\' '\r'? '\n'
+ { string b lexbuf }
| "\\\"" { Buffer.add_char b '"' ; string b lexbuf }
| _ { Buffer.add_char b (Lexing.lexeme_char lexbuf 0) ;
string b lexbuf }
============================================================
--- glib/giochannel.ml d2f7241bdc6af475022c162be25a383f61e9624c
+++ glib/giochannel.ml 43e1aac62aaa993eb3864f62c709539276740411
@@ -19,6 +19,7 @@ external unix_get_fd : t -> int = "ml_g_
external unix_new : int -> t = "_ml_g_io_channel_unix_new"
external unix_get_fd : t -> int = "ml_g_io_channel_unix_get_fd"
+external new_fd : int -> t = "ml_g_io_channel_new_fd"
external new_file : string -> string -> t = "ml_g_io_channel_new_file"
external read_chars : t -> ?off:int -> ?len:int -> string ->
@@ -49,6 +50,9 @@ external set_flags : t -> rw_flags list
type ro_flags = [ `IS_READABLE | `IS_SEEKABLE | `IS_WRITEABLE ]
external get_flags : t -> [ro_flags | rw_flags] list = "ml_g_io_channel_get_flags"
external set_flags : t -> rw_flags list -> unit = "ml_g_io_channel_set_flags"
+let set_flags_noerr c fl =
+ try set_flags c fl
+ with Error _ -> ()
external get_line_term : t -> string option = "ml_g_io_channel_get_line_term"
external set_line_term : t -> string option -> unit = "ml_g_io_channel_set_line_term"
============================================================
--- glib/giochannel.mli 0fd137687560f6951e5377ac213371df7135e53f
+++ glib/giochannel.mli a2531dbc99c8c1b2f808dff1a5a6dec3d4080b8d
@@ -15,6 +15,7 @@ external unix_get_fd : t -> int = "ml_g_
external unix_new : int -> t = "_ml_g_io_channel_unix_new"
external unix_get_fd : t -> int = "ml_g_io_channel_unix_get_fd"
+external new_fd : int -> t = "ml_g_io_channel_new_fd"
external new_file : string -> string -> t = "ml_g_io_channel_new_file"
external read_chars : t -> ?off:int -> ?len:int -> string ->
@@ -58,6 +59,7 @@ external set_flags : t -> rw_flags list
type ro_flags = [ `IS_READABLE | `IS_SEEKABLE | `IS_WRITEABLE ]
external get_flags : t -> [ro_flags | rw_flags] list = "ml_g_io_channel_get_flags"
external set_flags : t -> rw_flags list -> unit = "ml_g_io_channel_set_flags"
+val set_flags_noerr : t -> rw_flags list -> unit
external get_line_term : t -> string option = "ml_g_io_channel_get_line_term"
external set_line_term : t -> string option -> unit
============================================================
--- glib/ocaml-giochannel.c fb46e36577eb1803ec00649f0770c179b5ab71f4
+++ glib/ocaml-giochannel.c 6c3489c6443d057d2f3fce77a2d3465466c2ff93
@@ -55,6 +55,17 @@ ML_1(g_io_channel_unix_get_fd, GIOChanne
/* ML_1(g_io_channel_unix_new, Int_val, Val_GIOChannel) */
ML_1(g_io_channel_unix_get_fd, GIOChannel_val, Val_int)
+CAMLprim value ml_g_io_channel_new_fd (value fd)
+{
+ GIOChannel *c;
+#ifdef G_OS_WIN32
+ c = g_io_channel_win32_new_fd (Int_val (fd));
+#else
+ c = g_io_channel_unix_new (Int_val (fd));
+#endif
+ return Val_GIOChannel (c);
+}
+
CAMLprim value
ml_g_io_channel_new_file (value v_fname, value v_mode)
{
============================================================
--- glib/ocaml-gspawn.c 0f9699de08507b50e004ccefdd8f513ce6c1f07d
+++ glib/ocaml-gspawn.c 35c4485ece72c47122caf1f0729a436f07786753
@@ -1,4 +1,7 @@
#include <glib.h>
+#ifdef G_OS_UNIX
+# include <sys/wait.h>
+#endif
#include <caml/mlvalues.h>
#include <caml/alloc.h>
@@ -137,11 +140,11 @@ ML_bc6 (ml_g_spawn_async_with_pipes)
ML_bc6 (ml_g_spawn_async_with_pipes)
-#include <sys/wait.h>
static value
convert_exit_status (int status)
{
value r;
+#ifdef G_OS_UNIX
if (WIFEXITED(status))
{
r = alloc_small (1, 0);
@@ -159,6 +162,10 @@ convert_exit_status (int status)
}
else
invalid_argument ("Gspawn.sync: don't know how to convert the exit status");
+#else
+ r = alloc_small (1, 0);
+ Field (r, 0) = Val_long (status);
+#endif
return r;
}
============================================================
--- gnomecanvas_hack.c ed8e248d636d567cacfe4727a9370ee4283097af
+++ gnomecanvas_hack.c 0e28de5cf7f0ea5df027fee49bcb63056b2c27c5
@@ -1,5 +1,10 @@
#include <caml/mlvalues.h>
+#include <glib.h>
+
+
+#ifdef G_OS_UNIX
+
#include <libgnomecanvas/libgnomecanvas.h>
#include <pango/pangoft2.h>
@@ -82,3 +87,13 @@ ml_fix_libgnomecanvas_pango (value text_
return Val_unit;
}
+
+#else
+
+CAMLprim value
+ml_fix_libgnomecanvas_pango (value text_obj)
+{
+ return Val_unit;
+}
+
+#endif
============================================================
--- main.ml 4e7b15f2966740755d87d69522e02c1f47feefe9
+++ main.ml c97fd3746cf8966dfbf158a2a49b6812a1d35feb
@@ -6,24 +6,14 @@ type mtn_options =
| MTNopt_branch of string * string
| MTNopt_full of string * string * string
-let unquote s =
- if s.[0] = '"'
- then
- let len = String.length s in
- Revision_lexer.string
- (Buffer.create len)
- (Lexing.from_string (String.sub s 1 (len - 1)))
- else s
-
let find_MTN_dir base =
- let rec up = function
- | "/" -> raise Not_found
- | p ->
- let d = Filename.dirname p in
- let m = Filename.concat d base in
- if Sys.file_exists m
- then m
- else up d in
+ let rec up p =
+ let d = Filename.dirname p in
+ if d = p then raise Not_found ;
+ let m = Filename.concat d base in
+ if Sys.file_exists m
+ then m
+ else up d in
if Sys.file_exists base
then base
else up (Sys.getcwd ())
@@ -34,17 +24,15 @@ let parse_MTN_options mtn_file =
let parse_MTN_options mtn_file =
- let lines =
- try with_file_in input_lines (mtn_file "options")
+ let stanzas =
+ try
+ with_file_in
+ (fun ic -> Basic_io_lexer.parse (Lexing.from_channel ic))
+ (mtn_file "options")
with Not_found | Sys_error _ -> [] in
- try
- List.fold_right
- (fun s acc ->
- match string_split ~max_elem:2 ' ' s with
- | [a; b] -> (a, unquote b) :: acc
- | _ -> acc)
- lines []
- with Failure _ -> []
+ List.map
+ (fun (k, v) -> k, Basic_io_lexer.string_of_elem v)
+ (List.flatten stanzas)
let parse_MTN_revision mtn_file =
let format =
@@ -62,11 +50,10 @@ let parse_MTN_revision mtn_file =
with_file_in
(fun ic ->
match
- Revision_parser.revision_set
- Revision_lexer.lex
+ Revision.revision_set
(Lexing.from_channel ic)
with
- | _, { Revision_types.old_revision = r } :: _ -> r
+ | _, { Revision.old_revision = r } :: _ -> r
| _ -> failwith "could not determine revision id from _MTN/revision")
rev_file
| _ ->
@@ -117,7 +104,7 @@ let print_version () =
let print_version () =
Printf.printf "monotone-viz %s (base revision: %s)\n" Version.version Version.revision ;
- Printf.printf "Copyright (C) 2004-2005 Olivier Andrieu <oandrieu@nerim.net>\n" ;
+ Printf.printf "Copyright (C) 2004-2006 Olivier Andrieu <oandrieu@gmail.com>\n" ;
exit 0
let parse_cli () =
@@ -134,8 +121,6 @@ let exn_handler ctrl = function
let exn_handler ctrl = function
- | Sqlite3.Error ((Sqlite3.BUSY | Sqlite3.LOCKED), _) ->
- ()
| exn ->
ctrl#error_notice
begin
============================================================
--- query.ml f691b2a902e28ebb9503a018f52a1634297b39ed
+++ query.ml 0b0ca22a8260b482a15efbee2adf6619a34119bb
@@ -1,46 +1,20 @@
+open Viz_misc
open Viz_types
module Selector = struct
- let escape_selector s =
- let len = String.length s in
- let nb_escp = ref 0 in
- for i = 0 to len - 1 do
- let c = s.[i] in
- if c = '\\' || c = '/'
- then incr nb_escp
- done ;
- if !nb_escp = 0
- then s
- else begin
- let o = String.create (len + !nb_escp) in
- let j = ref 0 in
- for i = 0 to len - 1 do
- let c = s.[i] in
- if c = '\\' || c = '/'
- then (o.[!j] <- '\\' ; incr j) ;
- o.[!j] <- c ;
- incr j
- done ;
- assert (!j = len + !nb_escp) ;
- o
- end
-
let make_selectors g sel =
- match (Agraph.get_query g).dom with
- | QUERY_ALL ->
- [ escape_selector sel ]
- | QUERY_BRANCHES br ->
- List.map
- (fun b -> Printf.sprintf "b:%s/%s" (escape_selector b) (escape_selector sel))
- br
+ let br = (Agraph.get_query g).dom in
+ List.map
+ (fun b -> Printf.sprintf "b:%s/%s" (Monotone.escape_selector b) sel)
+ br
let running_select = ref None
let abort () =
match !running_select with
- | Some id ->
- Subprocess.abort id ;
+ | Some (mtn, id) ->
+ List.iter (Automate.abort mtn) id ;
running_select := None
| _ ->
()
@@ -53,17 +27,15 @@ module Selector = struct
`IDS (List.filter (Agraph.mem g) ids)
| x -> x
- let select ctrl db g sel cont =
- let id =
- Database.run_monotone_select
- db
- ctrl#get_prefs.Viz_style.monotone_path
- (ctrl#status "search")
+ let select mtn g sel cont =
+ let ids =
+ Monotone.select_async
+ mtn
(fun r ->
running_select := None ;
cont (filter_present g r))
(make_selectors g sel) in
- running_select := Some id
+ running_select := Some (mtn, ids)
end
@@ -71,16 +43,14 @@ let revision_contains pat = function
| [ _, changes ] ->
List.exists
(function
- | Revision_types.PATCH (f, _, _)
- | Revision_types.ADD_FILE (f, _)
- | Revision_types.ADD_DIR f
- | Revision_types.DELETE_FILE f
- | Revision_types.DELETE_DIR f
- | Revision_types.ATTR_CLEAR (_, f)
- | Revision_types.ATTR_SET (_, f, _) ->
+ | Revision.PATCH (f, _, _)
+ | Revision.ADD_FILE (f, _)
+ | Revision.ADD_DIR f
+ | Revision.DELETE f
+ | Revision.ATTR_CLEAR (_, f)
+ | Revision.ATTR_SET (_, f, _) ->
Gpattern.match_string pat f
- | Revision_types.RENAME_FILE (f1, f2)
- | Revision_types.RENAME_DIR (f1, f2) ->
+ | Revision.RENAME (f1, f2) ->
Gpattern.match_string pat f1 ||
Gpattern.match_string pat f2)
changes
@@ -90,30 +60,32 @@ let filter_by_revision_content
let filter_by_revision_content
(ctrl : <status : string -> <with_status : 'a. string -> (unit -> 'a) -> 'a; ..>; ..>)
- db revision_content ids =
+ mtn revision_content ids =
(ctrl#status "search")#with_status
"Searching the monotone database ..."
(fun () ->
let pat = Gpattern.make revision_content in
Ui.fold_in_loop
(fun acc id ->
- let r = Database.fetch_revision db id in
+ let r = Monotone.get_revision mtn id in
if revision_contains pat r.revision_set
then id :: acc
else acc)
[] ids)
-let select_by_revision_content ctrl db revision_content g =
+let select_by_revision_content ctrl mtn revision_content g =
filter_by_revision_content
- ctrl db revision_content
+ ctrl mtn revision_content
(Agraph.get_ids g)
-let expand_results db ids =
- let fetch_first_cert id c =
- match Database.fetch_cert_value db id c with
- | h :: _ -> h
- | [] -> "" in
+let expand_results mtn ids =
+ let fetch_first_cert id =
+ let get_cert = Monotone.cert_value mtn id in
+ fun c ->
+ match get_cert c with
+ | h :: _ -> h
+ | [] -> "" in
List.map
(fun id ->
@@ -126,26 +98,27 @@ let do_query ~selector ~revision_content
let do_query ~selector ~revision_content ctrl results_cb =
let no_results () =
results_cb (`IDS []) in
- let results_ids db ids =
- results_cb (`IDS (expand_results db ids)) in
+ let results_ids mtn ids =
+ results_cb (`IDS (expand_results mtn ids)) in
- match ctrl#get_db, ctrl#get_agraph with
- | Some db, Some g when selector <> "" ->
+ match ctrl#get_mtn, ctrl#get_agraph with
+ | Some mtn, Some g when selector <> "" ->
Selector.select
- ctrl db g selector
+ mtn g selector
(function
| `IDS ids when revision_content <> "" ->
- results_ids db
+ results_ids
+ mtn
(filter_by_revision_content
- ctrl db revision_content ids)
+ ctrl mtn revision_content ids)
| `IDS ids ->
- results_ids db ids
+ results_ids mtn ids
| `SUB_PROC_ERROR _ as err ->
results_cb err)
- | Some db, Some g when revision_content <> "" ->
- results_ids db
+ | Some mtn, Some g when revision_content <> "" ->
+ results_ids mtn
(select_by_revision_content
- ctrl db revision_content g)
+ ctrl mtn revision_content g)
| _ ->
no_results ()
============================================================
--- subprocess.ml e1f23ae41fa3d03977419f2f102646e0ad32d546
+++ subprocess.ml 2d064944dda534981a86b13dbc018a47bfcf5576
@@ -14,8 +14,8 @@ let setup_channel ~nonblock encoding fd
let setup_channel ~nonblock encoding fd =
- let chan = Giochannel.unix_new (some fd) in
- if nonblock then Giochannel.set_flags chan [`NONBLOCK] ;
+ let chan = Giochannel.new_fd (some fd) in
+ if nonblock then Giochannel.set_flags_noerr chan [`NONBLOCK] ;
begin
match encoding with
| `NONE ->
@@ -134,6 +134,8 @@ let spawn ~encoding ~cmd ~input:input_op
}
let spawn ~encoding ~cmd ~input:input_opt ~reap_callback done_callback =
+ if Viz_misc.debug "exec"
+ then Printf.eprintf "### exec: Running '%s'\n%!" (String.concat " " cmd) ;
let has_input = input_opt <> None in
let spawn_flags =
[ `PIPE_STDOUT ; `PIPE_STDERR ;
============================================================
--- ui.ml 89f9af8477b455fc355375fdc5edbc0f7d3a9241
+++ ui.ml 11001bc610a51475ab918f26ede093f811e69e0e
@@ -32,9 +32,6 @@ let pump () =
let pump () =
while Glib.Main.iteration false do () done
-let nice_fetch f db =
- with_grab (fun () -> Database.with_progress pump f db)
-
let fold_in_loop ?(granularity=10) f init l =
with_grab (fun () ->
let i = ref 0 in
@@ -208,7 +205,6 @@ module Prefs = struct
if group = None then Some b#group else group)
None
[ "no automatic coloring", NONE ;
- "color by key_id", BY_KEYID ;
"color by author", BY_AUTHOR_HASH ;
"color by branch", BY_BRANCH_HASH ] )
end ;
@@ -265,8 +261,39 @@ end
end
+module About = struct
+ let authors = ["Olivier Andrieu <oandrieu@gmail.com>"]
+ let comments = "Lets you visualize ancestry graphs from the Revision Control System monotone"
+ let copyright = "Copyright © 2004-2007 Olivier Andrieu"
+ let license = "\
+monotone-viz is free software; you can redistribute it
+and/or modify it under the terms of the GNU General
+Public License as published by the Free Software Foundation;
+either version 2 of the License, or (at your option)
+any later version."
+ let name = "monotone-viz"
+ let version = Version.version
+ let website = "http://oandrieu.nerim.net/monotone-viz/"
+ let website_label = "monotone-viz website"
+
+ let make ctrl =
+ let d =
+ GWindow.about_dialog
+ ~authors ~comments ~copyright
+ ~license ~logo:(Lazy.force Icon.monotone)
+ ~name ~version ~website ~website_label
+ ~parent:ctrl#get_toplevel () in
+ ignore (d#event#connect#delete (fun _ -> d#misc#hide () ; true)) ;
+ ignore (d#connect#response (fun _ -> d#misc#hide ())) ;
+ d
+
+ let show ctrl =
+ let d = lazy (make ctrl) in
+ fun () -> (Lazy.force d)#present ()
+end
+
module Open = struct
type t = [`OPEN|`CLOSE|`DELETE_EVENT] GWindow.file_chooser_dialog
let make ctrl =
@@ -288,6 +315,7 @@ end
resp
end
+(*
module LockedDB = struct
let message ctrl =
@@ -337,7 +365,7 @@ end
resp
end
-
+*)
@@ -375,6 +403,9 @@ let ui_info = "\
<menuitem action='Zoom_out'/>\
<menuitem action='Query'/>\
</menu>\
+ <menu action='HelpMenu'>\
+ <menuitem action='About'/>\
+ </menu>\
</menubar>\
<accelerator action='FindEntry'/>\
</ui>"
@@ -405,7 +436,9 @@ let make_groups () =
add "Open" ~stock:`OPEN ~tooltip:"Open a database" ;
add "Quit" ~stock:`QUIT ~tooltip:"Exit" ;
add "Prefs" ~stock:`PREFERENCES ~tooltip:"Edit Preferences" ;
- add "FindEntry" ~accel:"<Ctrl>l" ] ;
+ add "FindEntry" ~accel:"<Ctrl>l" ;
+ add "HelpMenu" ~label:"_Help" ;
+ add "About" ~stock:`ABOUT ] ;
let g_db = GAction.action_group ~name:"db" () in
GAction.add_actions g_db [
add "Close" ~stock:`CLOSE ~tooltip:"Close the database" ;
@@ -490,7 +523,7 @@ let popup m ctrl ~popup_id button =
begin
let copy_revision = p.group#get_action "Copy_revision" in
let copy_manifest = p.group#get_action "Copy_manifest" in
- let data = Database.fetch_revision (some ctrl#get_db) popup_id in
+ let data = Monotone.get_revision (some ctrl#get_mtn) popup_id in
remember_signal copy_revision
(fun () -> set_clipboard m data.revision_id) ;
remember_signal copy_manifest
@@ -542,6 +575,25 @@ let popup m ctrl ~popup_id button =
+let automate_cb auto o =
+ begin
+ match o with
+ | `OUTPUT msg ->
+ Printf.eprintf "### automate: output '%s'\n%!" (String.escaped msg) ;
+ let message = Printf.sprintf "<tt><b>interface_version</b>: %s</tt>" msg in
+ let d =
+ GWindow.message_dialog
+ ~message ~use_markup:true
+ ~message_type:`INFO
+ ~buttons:GWindow.Buttons.close () in
+ ignore (d#run ()) ;
+ d#destroy ()
+ | `SYNTAX_ERROR msg ->
+ Printf.eprintf "### automate: syntax error '%s'\n%!" msg
+ | `ERROR msg ->
+ Printf.eprintf "### automate: error '%s'\n%!" msg
+ end ;
+ ignore (Glib.Timeout.add 5000 (fun () -> Automate.exit auto ; false))
@@ -571,6 +623,7 @@ let setup ({ manager = ui } as m) ctrl =
action_connect "/menubar/FileMenu/Prefs" ctrl#show_prefs ;
action_connect "/menubar/ViewMenu/Query" ctrl#show_search ;
action_connect "/menubar/FileMenu/New" ctrl#show_view ;
+ action_connect "/menubar/HelpMenu/About" (About.show ctrl) ;
action_connect "/popup/Certs"
(fun () -> ctrl#display_certs (get_popup_data m).popup_id) ;
action_connect "/popup_cert/Copy_cert"
@@ -578,7 +631,7 @@ let setup ({ manager = ui } as m) ctrl =
may
(set_clipboard m)
ctrl#get_current_cert_value) ;
- action_connect "/FindEntry" ctrl#focus_find_entry
+ action_connect "/FindEntry" ctrl#focus_find_entry
let open_db m ctrl =
============================================================
--- ui.mli d25fe1553276726e4cd998b1010d280139e5534b
+++ ui.mli eb8ae605a812037deaa0f8bf4d9f7b3d744aed13
@@ -4,7 +4,7 @@ val error_notice_f :
val error_notice_f :
parent:#GWindow.window_skel -> ('a, unit, string, unit) format4 -> 'a
-val nice_fetch : (Database.t -> 'a) -> Database.t -> 'a
+val with_grab : (unit -> 'a) -> 'a
val fold_in_loop : ?granularity:int -> ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
val wrap_in_scroll_window : (GObj.widget -> unit) -> GObj.widget -> unit
@@ -41,9 +41,11 @@ end
val show : t -> string option
end
+(*
module LockedDB : sig
val show : #App.t -> [`FAIL | `RETRY]
end
+*)
type manager
val make : unit -> manager * GObj.widget * GObj.widget
============================================================
--- unidiff.ml 6446132389b142a377ad1922e73e7104241c88a6
+++ unidiff.ml a84b8a696a2e5075b1cfe0ced654bcfe367f7002
@@ -228,13 +228,12 @@ let show ctrl old_id new_id =
d#show ()
let show ctrl old_id new_id =
- match ctrl#get_db with
+ match ctrl#get_mtn with
| None -> ()
- | Some db ->
+ | Some mtn ->
try
- Database.run_monotone_diff
- db
- ctrl#get_prefs.Viz_style.monotone_path
+ Monotone.run_monotone_diff
+ mtn
(ctrl#status "monotone")
(fun res ->
match res with
============================================================
--- view.ml e2d0e8ea6928c04c7002e37d08aee0c5de5a1c3e
+++ view.ml 60ed1b72ef4581b1b5bd247f86c921b877ca2384
@@ -1,6 +1,6 @@ open Viz_types
open Viz_misc
open Viz_types
-open Revision_types
+open Revision
open Ui
let ( ++ ) x f = f x
@@ -188,14 +188,12 @@ module Info_Display = struct
i.cert_model#clear ()
let stock_of_delta_type = function
- | PATCH _ -> None
+ | PATCH _ -> None
| ADD_FILE _
- | ADD_DIR _ -> Some `ADD
- | DELETE_FILE _
- | DELETE_DIR _ -> Some `REMOVE
- | RENAME_FILE _
- | RENAME_DIR _ -> Some `CONVERT
- | ATTR_SET _ -> Some `PROPERTIES
+ | ADD_DIR _ -> Some `ADD
+ | DELETE _ -> Some `REMOVE
+ | RENAME _ -> Some `CONVERT
+ | ATTR_SET _ -> Some `PROPERTIES
| ATTR_CLEAR _ -> Some `CLEAR
let text_of_delta_type = function
@@ -203,11 +201,9 @@ module Info_Display = struct
| PATCH (f, _, "") -> ""
| PATCH (f, _, _)
| ADD_FILE (f, _)
- | DELETE_FILE f -> f
- | ADD_DIR f
- | DELETE_DIR f -> f ^ "/"
- | RENAME_FILE (o, n) -> Printf.sprintf "%s -> %s" o n
- | RENAME_DIR (o, n) -> Printf.sprintf "%s/ -> %s/" o n
+ | DELETE f -> f
+ | ADD_DIR f -> f ^ "/"
+ | RENAME (o, n) -> Printf.sprintf "%s -> %s" o n
| ATTR_CLEAR (attr, f)
| ATTR_SET (attr, f, _) -> Printf.sprintf "%s on %s" attr f
@@ -275,14 +271,12 @@ module Info_Display = struct
{ data with certs = List.filter (fun c -> not (List.mem c.c_name ignored_certs)) data.certs }
let fetch_and_display_data info ctrl id =
- match ctrl#get_db with
+ match ctrl#get_mtn with
| None -> ()
- | Some db ->
+ | Some mtn ->
let data =
- try Database.fetch_certs_and_revision db id
+ try Monotone.get_certs_and_revision mtn id
with
- | Sqlite3.Error ((Sqlite3.BUSY | Sqlite3.LOCKED), _) ->
- failed_node_data
| Viz_types.Error msg ->
ctrl#error_notice msg ;
failed_node_data in
@@ -302,43 +296,10 @@ module Complete = struct
module Complete = struct
- let is_id =
- let re = Str.regexp "^[0-9a-fA-F]+$" in
- fun id -> Str.string_match re id 0
-
let is_date =
let re = Str.regexp "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]" in
fun id -> Str.string_partial_match re id 0
- let complete_with_db ctrl f =
- match ctrl#get_db with
- | None -> []
- | Some db -> f db
-
- let complete_id ctrl query_domain q =
- complete_with_db ctrl
- (fun db ->
- let data = Database.get_matching_ids db q in
- match query_domain with
- | QUERY_ALL -> data
- | QUERY_BRANCHES allowed_branches ->
- List.filter
- (fun (_, branch_name) -> List.mem branch_name allowed_branches)
- data)
-
- let complete_tag ctrl q =
- complete_with_db ctrl
- (fun db ->
- let re = Str.regexp q in
- Database.get_matching_tags db
- (fun t -> Str.string_match re t 0))
-
- let get_id_and_uniquify data =
- data
- ++ List.map fst
- ++ List.sort compare
- ++ Viz_misc.list_uniq
-
let several_completions parent (t, ids) =
let txt = Buffer.create 128 in
Printf.bprintf txt
@@ -360,27 +321,26 @@ module Complete = struct
ignore (m#connect#response (fun _ -> m#destroy ())) ;
m#show ()
- exception None
+ exception None_
exception Many of (string * string list)
let complete_date ctrl domain t =
if is_date t
then t
else
- let match_data =
- if is_id t
- then complete_id ctrl domain t
- else complete_tag ctrl t in
- match get_id_and_uniquify match_data with
- | [] -> raise None
- | [ id ] ->
- begin
- match Database.fetch_cert_value (some ctrl#get_db) id "date" with
- | t :: _ -> t
- | [] -> raise None
- end
- | ids ->
- raise (Many (t, ids))
+ match ctrl#get_mtn with
+ | None -> raise None_
+ | Some mtn ->
+ match Monotone.select mtn t with
+ | [] -> raise None_
+ | [ id ] ->
+ begin
+ match Monotone.cert_value mtn id "date" with
+ | t :: _ -> t
+ | [] -> raise None_
+ end
+ | ids ->
+ raise (Many (t, ids))
end
@@ -567,31 +527,24 @@ module Branch_selector = struct
s.view#scroll_to_cell path (s.view#get_column 0)
let get_query_domain s =
- let all = ref true in
let acc = ref [] in
s.store#foreach
(fun path row ->
let v = s.store#get ~row ~column:s.in_view_column in
- all := !all && v ;
if v
then begin
let b = s.store#get ~row ~column:s.branch_column in
acc := b :: !acc
end ;
false) ;
- if !all
- then QUERY_ALL
- else QUERY_BRANCHES !acc
+ !acc
- let future = "9999-12"
- let past = "0001-01"
-
let make_query_limit_interval ctrl domain s_from s_to =
- let t_from = Complete.complete_date ctrl domain
- (if s_from = "" then past else s_from) in
- let t_to = Complete.complete_date ctrl domain
- (if s_to = "" then future else s_to) in
- QUERY_BETWEEN (t_from, t_to)
+ let t_from = Complete.complete_date ctrl domain s_from in
+ let t_to = Complete.complete_date ctrl domain s_to in
+ if t_from = "" && t_to = ""
+ then QUERY_NO_LIMIT
+ else QUERY_BETWEEN (t_from, t_to)
let make_query ctrl ?id s =
@@ -611,7 +564,7 @@ module Branch_selector = struct
all_propagates = query_propagate };
preselect = id }
with
- | Complete.None -> None
+ | Complete.None_ -> None
| Complete.Many compl ->
Complete.several_completions s.w compl ; None
@@ -750,10 +703,7 @@ module Branch_selector = struct
let set_state s ctrl ?id state =
s.w#misc#hide () ;
let (domain, limit_kind, entries_text) = state in
- let in_domain v =
- match domain with
- | QUERY_ALL -> true
- | QUERY_BRANCHES b -> List.mem v b in
+ let in_domain v = List.mem v domain in
s.selected_b <- 0 ;
s.store#foreach
(fun path row ->
@@ -805,8 +755,8 @@ module Branch_selector = struct
s.entries.(1)#set_text ""
| Some id ->
match
- Database.fetch_cert_value
- (some ctrl#get_db) id "date"
+ Monotone.cert_value
+ (some ctrl#get_mtn) id "date"
with
| [] ->
s.radio_buttons.(0)#set_active true
@@ -874,10 +824,10 @@ module KeyNav = struct
let navigate_is_sibling k id =
List.exists (fun (i, _) -> i = id) k.keyboard_nav_siblings
- let on_same_branch db id =
- let b_target = Database.fetch_cert_value db id "branch" in
+ let on_same_branch mtn id =
+ let b_target = Monotone.cert_value mtn id "branch" in
fun (id, _) ->
- let b_node = Database.fetch_cert_value db id "branch" in
+ let b_node = Monotone.cert_value mtn id "branch" in
List.exists
(fun b -> List.mem b b_target)
b_node
@@ -895,7 +845,7 @@ module KeyNav = struct
| `NEXT -> locate sx
| `PREV -> locate (List.rev sx)
| `PARENT | `CHILD ->
- match List.filter (on_same_branch (some ctrl#get_db) current_id) sx with
+ match List.filter (on_same_branch (some ctrl#get_mtn) current_id) sx with
| [] -> Some (List.hd sx)
| h :: _ -> Some h
@@ -1171,7 +1121,7 @@ module Canvas = struct
let canvas = c.canvas in
let graph = some ctrl#get_agraph in
let layout = Agraph.get_layout graph in
- let db = some ctrl#get_db in
+ let mtn = some ctrl#get_mtn in
let pr = ctrl#status "canvas" in
let prefs = ctrl#get_prefs in
let lr_layout = prefs.Viz_style.lr_layout in
@@ -1219,7 +1169,7 @@ module Canvas = struct
let font = prefs.Viz_style.font in
let font_size = get_font_size font in
- let match_style = Viz_style.match_style prefs graph db in
+ let match_style = Viz_style.match_style prefs graph mtn in
let node_item id node () =
let g = GnoCanvas.group ~x:node.n_x ~y:node.n_y nodes_group in
@@ -1271,7 +1221,7 @@ module Canvas = struct
false end
| `TWO_BUTTON_PRESS b when is_neighbor node && GdkEvent.Button.button b = 1 ->
begin
- match Database.fetch_cert_value db id "branch" with
+ match Monotone.cert_value mtn id "branch" with
| other_branch :: _ ->
ctrl#switch_branch (other_branch, id)
| [] -> ()
@@ -1406,7 +1356,7 @@ module Find = struct
begin
let tooltips = GData.tooltips () in
tooltips#set_tip
- ~text:"Find a node by its revision id, tag or date (YYYY-MM-DD)"
+ ~text:"Find a node using a monotone selector"
entry#coerce
end ;
add_label ~text:"Find:" ~packing ;
@@ -1420,58 +1370,29 @@ module Find = struct
find.find_entry#set_text "" ;
find.last_find <- "", []
- let locate_id ctrl id =
+ let order lr_layout (_, n1) (_, n2) =
+ if lr_layout
+ then compare n1.n_x n2.n_x
+ else compare n1.n_y n2.n_y
+
+ let filter_in_agraph ctrl ids =
match ctrl#get_agraph with
| None -> []
| Some g ->
- let id = String.lowercase id in
- if String.length id < 2
- then []
- else
- NodeMap.fold
- (fun k n acc ->
- if string_is_prefix id k
- then (k, n) :: acc
- else acc)
- (Agraph.get_layout g).c_nodes []
+ ids
+ ++ List.filter (Agraph.mem g)
+ ++ List.map (Agraph.get_node g)
+ ++ List.sort (order ctrl#get_prefs.Viz_style.lr_layout)
+
- let locate_with_db ctrl f =
- match ctrl#get_db with
- | None -> []
- | Some db ->
- match ctrl#get_agraph with
- | None -> []
- | Some g ->
- f db
- ++ List.filter (fun (id, _) -> Agraph.mem g id)
- ++ List.sort (fun (_,a) (_,b) -> compare a b)
- ++ List.map (fun (id, _) -> Agraph.get_node g id)
-
- let locate_date ctrl date_prefix =
- locate_with_db ctrl
- (fun db -> Database.get_matching_dates db date_prefix)
-
- let locate_tag ctrl q =
- locate_with_db ctrl
- (fun db ->
- let re = Str.regexp q in
- Database.get_matching_tags db
- (fun t -> Str.string_match re t 0))
-
let locate find ctrl q =
match find.last_find with
| (last_q, n :: t) when last_q = q ->
find.last_find <- (last_q, t) ;
ctrl#center_on n
| _ ->
- let candidates =
- try
- if Complete.is_id q
- then locate_id ctrl q
- else if Complete.is_date q
- then locate_date ctrl q
- else locate_tag ctrl q
- with Failure _ | Invalid_argument _ -> [] in
+ let ids = Monotone.select (some ctrl#get_mtn) q in
+ let candidates = filter_in_agraph ctrl ids in
match candidates with
| [] ->
find.last_find <- (q, [])
@@ -1534,7 +1455,11 @@ let open_db v ctrl =
let open_db v ctrl =
Branch_selector.populate
v.selector
- (Ui.nice_fetch Database.fetch_branches (some ctrl#get_db))
+ (Ui.with_grab (fun () ->
+ let mtn = some ctrl#get_mtn in
+ let b = Monotone.branches mtn
+ and c = Monotone.run_monotone_count_branches mtn in
+ List.map (fun b -> b, c b) b))
let update v ctrl id =
Canvas.update_graph v.canvas ctrl id
============================================================
--- viz_misc.ml 6fd0c3f159b19117f0baf4570c3cec8b0a24aedc
+++ viz_misc.ml 962f45ead1ad16c50548c9a69a360d70940d195e
@@ -57,6 +57,14 @@ let rec list_rassoc v = function
| _ :: tl -> list_rassoc v tl
| [] -> raise Not_found
+let list_filter_map p f l =
+ List.fold_left
+ (fun acc e ->
+ if p e
+ then f e :: acc
+ else acc)
+ [] l
+
let array_index a v =
let rec loop i =
if i >= Array.length a
@@ -203,3 +211,10 @@ let make_cache g =
let v = g k in
Hashtbl.add tbl k v ;
v
+
+let hashtbl_of_list l =
+ let tbl = Hashtbl.create (List.length l) in
+ List.iter
+ (fun (k, v) -> Hashtbl.add tbl k v)
+ l ;
+ tbl
============================================================
--- viz_misc.mli 0cfad473122dc2494c4886ebf8ec3d362ef7ea5a
+++ viz_misc.mli 1ab258dd15c9db682622c137aa1bb2db6b903ee4
@@ -8,6 +8,7 @@ val list_rassoc : 'b -> ('a * 'b) list -
val list_uniq : 'a list -> 'a list
val list_assoc_all : 'a -> ('a * 'b) list -> 'b list
val list_rassoc : 'b -> ('a * 'b) list -> 'a (** @raise Not_found *)
+val list_filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list
val array_index : 'a array -> 'a -> int (** @raise Not_found *)
val some : 'a option -> 'a
@@ -41,3 +42,5 @@ val make_cache : ('a -> 'b) -> 'a -> 'b
val hex_enc : string -> string
val make_cache : ('a -> 'b) -> 'a -> 'b
+
+val hashtbl_of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t
============================================================
--- viz_style.ml 9f453028636cbd6f0dbc058a8cbb38a4880c563e
+++ viz_style.ml ffc50f7030fd216bdf9de1fc1dcc3cfba295e98a
@@ -38,13 +38,11 @@ let autocolor_of_item = function
let autocolor_of_item = function
| `STRING "none" | `BOOL false -> NONE
- | `STRING "key" | `STRING "keyid" -> BY_KEYID
| `STRING "author" -> BY_AUTHOR_HASH
| `STRING "branch" -> BY_BRANCH_HASH
| _ -> failwith "autocolor_of_item"
let string_of_autocolor = function
| NONE -> "none"
- | BY_KEYID -> "key"
| BY_AUTHOR_HASH -> "author"
| BY_BRANCH_HASH -> "branch"
let item_of_autocolor ac =
@@ -95,11 +93,11 @@ type text_props = [
| `FONT of string
| `WEIGHT of int]
-let match_style { autocolor = autocolor_pref ; style = style } g db =
- let autocolor = Autocolor.autocolor autocolor_pref db in
+let match_style { autocolor = autocolor_pref ; style = style } g mtn =
+ let autocolor = Autocolor.autocolor autocolor_pref in
fun id (default_rect_props, default_txt_props) ->
- let get_cert n = Database.fetch_cert_value db id n in
+ let get_cert = Monotone.cert_value mtn id in
let matching_attrs =
List.fold_left
@@ -154,9 +152,8 @@ let match_style { autocolor = autocolor_
else begin
let autocolor_key =
match autocolor_pref with
- | BY_KEYID -> Database.fetch_cert_signer db id "branch"
- | BY_AUTHOR_HASH -> Database.fetch_cert_value db id "author"
- | BY_BRANCH_HASH -> Database.fetch_cert_value db id "branch"
+ | BY_AUTHOR_HASH -> get_cert "author"
+ | BY_BRANCH_HASH -> get_cert "branch"
| NONE -> [] in
`FILL_COLOR_RGBA (autocolor autocolor_key) :: cleanup_rect_props
end in
@@ -245,7 +242,7 @@ let defaults =
let defaults =
{
font = "Monospace 8" ;
- autocolor = BY_KEYID ;
+ autocolor = BY_AUTHOR_HASH ;
lr_layout = false ;
monotone_path = "mtn" ;
dot_path = "dot" ;
============================================================
--- viz_style.mli 0ef255a1d99f080be0f2fceb5b35bb34f9dd7644
+++ viz_style.mli 39f0bf6b8542af069ba332237282b9eb42b873d2
@@ -28,7 +28,7 @@ val match_style :
val match_style :
prefs ->
Agraph.t ->
- Database.t ->
+ Monotone.t ->
string ->
shape_props list * text_props list ->
[> shape_props | `FILL_COLOR_RGBA of int32] list * [> text_props] list
============================================================
--- viz_types.ml 000e61799446f6d11caad5379ca79c9ea6ff087e
+++ viz_types.ml df6981aa67f5a7519900dbb06f38b96771db6919
@@ -5,9 +5,7 @@ module StringMap = Map.Make(String)
module StringMap = Map.Make(String)
-type query_domain =
- | QUERY_ALL
- | QUERY_BRANCHES of string list
+type query_domain = string list
type date = string
type query_limit =
| QUERY_NO_LIMIT
@@ -64,7 +62,7 @@ type node_data = {
type node_data = {
revision_id : string ;
manifest_id : string ;
- revision_set : (string * Revision_types.change list) list ;
+ revision_set : (string * Revision.change list) list ;
certs : cert list ;
}
@@ -115,6 +113,5 @@ type autocolor =
type autocolor =
| NONE
- | BY_KEYID
| BY_AUTHOR_HASH
| BY_BRANCH_HASH
============================================================
--- viz_types.mli dcc5514fcad957dbccfe3b83c2878fe91dc605b0
+++ viz_types.mli dc1b80f54bce2e6327b1d8de16d0a5762f3293a9
@@ -7,9 +7,7 @@ module StringMap : Map.S with type key =
module StringMap : Map.S with type key = string
-type query_domain =
- | QUERY_ALL
- | QUERY_BRANCHES of string list
+type query_domain = string list
type date = string
type query_limit =
| QUERY_NO_LIMIT
@@ -61,7 +59,7 @@ type node_data = {
type node_data = {
revision_id : string ;
manifest_id : string ;
- revision_set : (string * Revision_types.change list) list ;
+ revision_set : (string * Revision.change list) list ;
certs : cert list ;
}
@@ -115,6 +113,5 @@ type autocolor =
type autocolor =
| NONE
- | BY_KEYID
| BY_AUTHOR_HASH
| BY_BRANCH_HASH