The unified diff between revisions [0f4dc575..] and [c08f940c..] is displayed below. It can also be downloaded as a raw diff.
#
#
# add_file "components.ml"
# content [fdf1303aaef59ea1ff82b4e6c58df0ae346f406d]
#
# patch "Makefile"
# from [e24ee4ebcb8c535231a27e69c5bab89976e9b9d8]
# to [7313b6fe6e86645b4c3842bcd6187ad128f82567]
#
# patch "agraph.ml"
# from [0249f50c3a735aa63a946d8b9bcaa6471cbd9027]
# to [eae19057fcbb38e28ed2944db60bce98ab3a3329]
#
# patch "config.make.in"
# from [f5c8ece6dbb2201a5a0d666c353b4b0346aa8f3a]
# to [2ce163755bfad2267000b306499b53e0ff5140a9]
#
# patch "crypto/ocaml-openssl.c"
# from [bd3288f3e6bd88bb3eadf596387c64d473a311cb]
# to [d8e9766c3e2818b722b4582213ebc1e21d1d8f94]
#
# patch "database-mt.ml"
# from [4f652fbc8f02cf793f9f61724fee5ce446e201b8]
# to [dc682bbab8f0c49c3feeccf09cb680b4d2f2e97b]
#
# patch "mlsqlite/ocaml-sqlite3.c"
# from [4ffd05f56bd87954d1295b3b1fbd46e24de422cf]
# to [6a916beee78d7ca2f9d9293703503409051b3e9c]
#
# patch "q.ml"
# from [cf55d43e61d6525f3b37d10d6c06136315130d14]
# to [98e2ccc98fc3aa19c76b4495b02ab545140383d0]
#
# patch "q.mli"
# from [cad6dbc2092945f66504635d44bbb422a24439ec]
# to [511ce70836c714a8a1313eb984dcf7144f751e78]
#
# patch "ui.ml"
# from [7d827512c7a6b458a55372e159cfc7048e1ae789]
# to [1f4fb2a2e62a329da2e0f41bbaff2551a46c22aa]
#
# patch "unidiff.ml"
# from [50aa596af4116bc72ddd7fd6e05c030f91102881]
# to [5b365e84428d582c26bc14e5ae1c4c3f7d62abea]
#
# patch "view.ml"
# from [69c88b304f62c440cbc49ec4c62a89a98a42da90]
# to [590a55ffdf7771966025cd399911f5761dd53658]
#
# patch "viz_misc.ml"
# from [c0f7e882e80792536f5ec1e63695211c306a66e6]
# to [3480861e960d4f97092d197316e8032766a24b9e]
#
# patch "viz_misc.mli"
# from [3a6714c41817a7f1c71d6852e4cc45b7c4962871]
# to [143f89f5d846cb9ed5603040321df691a98e33b1]
#
# patch "viz_types.ml"
# from [dbec817290ee9b0c728f86dd6a2a51cb323aaaa2]
# to [81a02391285185725a67343f32a8f08fb8c94989]
#
# patch "viz_types.mli"
# from [0fb667537f24abfc4a2bc557ac00aeb1906830a1]
# to [53b8aa3cf55af126fe3ce9b6e68ee43c139e2875]
#
============================================================
--- components.ml fdf1303aaef59ea1ff82b4e6c58df0ae346f406d
+++ components.ml fdf1303aaef59ea1ff82b4e6c58df0ae346f406d
@@ -0,0 +1,185 @@
+open Viz_types
+
+(* find the connected components of the ancestry subgraph. *)
+let components subgraph =
+ let already_seen comp_list id =
+ List.exists (NodeMap.mem id) comp_list in
+
+ let rec add_to_comp comp = function
+ | [] ->
+ comp
+ | node :: tl when NodeMap.mem node.id comp ->
+ add_to_comp comp tl
+ | node :: tl ->
+ let comp = NodeMap.add node.id node comp in
+ let tl =
+ List.fold_left
+ (fun acc (rel_id, _) ->
+ if NodeMap.mem rel_id comp
+ then acc
+ else
+ try (NodeMap.find rel_id subgraph) :: acc
+ with Not_found -> acc)
+ tl
+ node.family in
+ add_to_comp comp tl in
+
+ NodeMap.fold
+ (fun id node acc ->
+ if already_seen acc id
+ then acc
+ else (add_to_comp NodeMap.empty [ node ]) :: acc)
+ subgraph
+ []
+
+
+(* A not-too-dumb DFS (ie tail-recursive) *)
+
+type 'a dfs_data =
+ | Nil
+ | Node of 'a * 'a dfs_data
+ | Child of 'a * 'a dfs_data
+
+let rec explore get_children f ((explored, f_acc) as acc) = function
+ | Nil ->
+ acc
+ | Node (node, tl)
+ | Child (node, tl) when IdSet.mem node.id explored ->
+ explore get_children f acc tl
+ | Node (node, tl) ->
+ explore get_children f
+ (IdSet.add node.id explored, f node f_acc)
+ tl
+ | Child (child, tl) ->
+ explore get_children f
+ acc
+ (get_children child
+ (fun acc child -> Child (child, acc))
+ (Node (child, tl)))
+
+let dfs subgraph get_children f init =
+ let (_, res) =
+ NodeMap.fold
+ (fun _ node acc ->
+ if List.for_all (function (_, PARENT) -> false | (_, CHILD) -> true) node.family
+ then explore get_children f acc (Child (node, Nil))
+ else acc)
+ subgraph
+ (IdSet.empty, init) in
+ res
+
+
+let fold_children g node f init =
+ List.fold_left
+ (fun acc -> function
+ | (_, PARENT) ->
+ acc
+ | (rel_id, CHILD) ->
+ try f acc (NodeMap.find rel_id g)
+ with Not_found -> acc)
+ init node.family
+
+let topo_sort_neighbors subgraph =
+ List.rev
+ (dfs
+ subgraph
+ (fold_children subgraph)
+ (fun node acc ->
+ if node.kind = NEIGHBOUR_IN || node.kind = NEIGHBOUR_OUT
+ then node :: acc
+ else acc)
+ [])
+
+
+let rec explore_bis get_children f explored q =
+ match Q.pop q with
+ | None ->
+ (None, explored)
+ | Some (node, tl) when IdSet.mem node explored ->
+ explore_bis get_children f explored tl
+ | Some (node, tl) ->
+ let explored = IdSet.add node explored in
+ match f node with
+ | `ACCEPT ->
+ (Some node, explored)
+ | `REJECT ->
+ explore_bis get_children f explored tl
+ | `CONTINUE ->
+ explore_bis get_children f explored
+ (get_children node Q.push tl)
+
+let rec apply_till_found f acc = function
+ | [] -> None
+ | h :: tl ->
+ match f acc h with
+ | (None, acc) ->
+ apply_till_found f acc tl
+ | (v, _) -> v
+
+
+let reconnect fetch_children agraph =
+ match components agraph.nodes with
+ | [] | [_] ->
+ Viz_misc.log "comp" "connected graph" ;
+ agraph
+
+ | comps ->
+ Viz_misc.log "comp" "%d components" (List.length comps) ;
+
+ let comps_with_neighbors =
+ List.map (fun c -> c, topo_sort_neighbors c) comps in
+
+ if Viz_misc.debug "comp" then begin
+ List.iter
+ (fun (_, n_sorted) ->
+ Viz_misc.log "comp" "topo sort of component neighbors (%d):\n %s"
+ (List.length n_sorted)
+ (String.concat "\n "
+ (List.map (fun node -> node.id) n_sorted)))
+ comps_with_neighbors
+ end ;
+
+ let edges =
+ List.fold_left
+ (fun acc (comp, neighbors_sorted) ->
+ (* for each component, try to connect it to
+ at most one other component. *)
+
+ let opt_edge =
+ apply_till_found
+ (fun explored start_neighbor ->
+ match
+ explore_bis fetch_children
+ (fun node_id ->
+ try
+ let node = NodeMap.find node_id agraph.nodes in
+ if NodeMap.mem node_id comp
+ then `REJECT
+ else if node.kind = NEIGHBOUR_IN
+ then `ACCEPT
+ else begin
+ assert (node.kind = NEIGHBOUR_OUT) ;
+ `CONTINUE
+ end
+ with Not_found -> `CONTINUE)
+ explored
+ (fetch_children start_neighbor.id Q.push Q.empty)
+ with
+ | (Some target, e) ->
+ Viz_misc.log "comp"
+ "found an edge: %s -> %s" start_neighbor.id target ;
+ (Some (start_neighbor.id, target), e)
+ | (None, _) as r -> r)
+ IdSet.empty
+ neighbors_sorted in
+
+ match opt_edge with
+ | None -> acc
+ | Some edge ->
+ EdgeMap.add edge SPANNING acc)
+
+ agraph.ancestry
+
+ comps_with_neighbors in
+
+ { agraph with ancestry = edges }
============================================================
--- Makefile e24ee4ebcb8c535231a27e69c5bab89976e9b9d8
+++ Makefile 7313b6fe6e86645b4c3842bcd6187ad128f82567
@@ -1,9 +1,6 @@ include config.make
include config.make
-NAME = git-viz
-VERSION = 0.1
-
OCAMLNET := ocamlnet-0.97.1
EXTLIB := extlib-1.3
@@ -21,7 +18,7 @@ SRC = gspawn.ml gspawn.mli giochannel.ml
dot_lexer.ml dot_parser.ml dot_parser.mli \
revision_types.mli revision_lexer.ml revision_parser.ml revision_parser.mli \
subprocess.ml subprocess.mli \
- status.ml \
+ status.ml components.ml \
database.ml database.mli agraph.ml agraph.mli \
autocolor.ml autocolor.mli viz_style.ml viz_style.mli \
icon.ml unidiff.ml unidiff.mli \
@@ -50,6 +47,7 @@ DISTSRC = Makefile configure.ac config.m
glib/gspawn_tags.var glib/giochannel_tags.var \
crypto/ocaml-openssl.c crypto/crypto.ml crypto/crypto.mli
+LIB3RDPARTY_OBJ = $(C_OBJ)
ifeq ($(OCAMLBEST), opt)
git-viz: $(OBJX) lib3rdparty.a
@@ -66,7 +64,7 @@ lib3rdparty.a : $(C_OBJ)
ln -s git.ml $@
lib3rdparty.a : $(C_OBJ)
- ar crs lib3rdparty.a $^
+ ar crs lib3rdparty.a $(LIB3RDPARTY_OBJ)
glib/ocaml-gspawn.o : gspawn_tags.c gspawn_tags.h
glib/ocaml-giochannel.o : giochannel_tags.c giochannel_tags.h
@@ -92,7 +90,7 @@ PP = $(if $(findstring $(1),$(USE_P4)),-
$(OCAMLC) $(MLINCDIRS) $<
%.o : %.c
- cd $(<D) ; $(OCAMLC) $(CINCDIRS) $(<F)
+ cd $(<D) ; $(OCAMLC) $(CINCDIRS) $(if $(CPPFLAGS),-ccopt "$(CPPFLAGS)") $(<F)
%.c %.h : %.var
cd $(<D) ; $(LABLGTK_DIR)/varcc -static $(<F)
============================================================
--- agraph.ml 0249f50c3a735aa63a946d8b9bcaa6471cbd9027
+++ agraph.ml eae19057fcbb38e28ed2944db60bce98ab3a3329
@@ -53,7 +53,7 @@ let dot_format params agraph =
begin
(* regular (rectangular) nodes *)
!+ " node [shape=box, width = %f, height = %f] ;\n" params.box_w params.box_h ;
- do_nodes (fun n -> n.kind = REGULAR || n.kind = NEIGHBOUR)
+ do_nodes (fun n -> match n.kind with REGULAR | NEIGHBOUR_IN | NEIGHBOUR_OUT -> true | _ -> false)
end ;
begin
@@ -83,9 +83,12 @@ let dot_format params agraph =
begin
(* edges *)
EdgeMap.iter
- (fun (s, t) _ ->
- !+ " %S -> %S ;\n" s t ;
- if (NodeMap.find t agraph.nodes).kind = NEIGHBOUR
+ (fun (s, t) kind ->
+ !+ " %S -> %S " s t ;
+ if kind = SPANNING then !+ "[minlen = 5]" ;
+ !+ ";\n" ;
+ if IdSet.mem t agraph.neighbour_nodes
+ && not (IdSet.mem s agraph.neighbour_nodes)
then !+ " { rank = same ; %S ; %S }" s t)
agraph.ancestry
end ;
============================================================
--- config.make.in f5c8ece6dbb2201a5a0d666c353b4b0346aa8f3a
+++ config.make.in 2ce163755bfad2267000b306499b53e0ff5140a9
@@ -11,6 +11,9 @@ CRYPTO_LIB := /usr/lib/libcrypto.a
MONOTONE_DIR := @MONOTONE_DIR@
LABLGTK_DIR := @LABLGTK_DIR@
CRYPTO_LIB := /usr/lib/libcrypto.a
+SQLITE_CFLAGS := @SQLITE_CFLAGS@
+SQLITE_LIBS := @SQLITE_LIBS@
+CPPFLAGS := @CPPFLAGS@
NAME := @PACKAGE_NAME@
VERSION := @PACKAGE_VERSION@
============================================================
--- crypto/ocaml-openssl.c bd3288f3e6bd88bb3eadf596387c64d473a311cb
+++ crypto/ocaml-openssl.c d8e9766c3e2818b722b4582213ebc1e21d1d8f94
@@ -14,6 +14,7 @@
#include <caml/custom.h>
#include <caml/callback.h>
+#define UString_val(s) ((unsigned char *) (s))
#define block_size(s) (((s) - 1) / sizeof (value) + 1)
#define RC4_val(v) ((RC4_KEY *)(v))
@@ -25,7 +26,7 @@ ml_RC4_set_key (value s)
value k;
k = caml_alloc_small (block_size (sizeof (RC4_KEY)), Abstract_tag);
- RC4_set_key (RC4_val (k), caml_string_length (s), String_val (s));
+ RC4_set_key (RC4_val (k), caml_string_length (s), UString_val (s));
CAMLreturn (k);
}
@@ -36,7 +37,7 @@ ml_RC4 (value key, value in_s, value out
len = caml_string_length (in_s);
if (caml_string_length (out_s) != len)
caml_invalid_argument ("Crypto.rc4: string sizes differ");
- RC4 (RC4_val (key), len, String_val (in_s), String_val (out_s));
+ RC4 (RC4_val (key), len, UString_val (in_s), UString_val (out_s));
return Val_unit;
}
@@ -46,7 +47,7 @@ ml_SHA1 (value msg)
CAMLparam1 (msg);
value o;
o = caml_alloc_string (SHA_DIGEST_LENGTH);
- SHA1 (String_val (msg), caml_string_length (msg), String_val (o));
+ SHA1 (UString_val (msg), caml_string_length (msg), UString_val (o));
CAMLreturn (o);
}
@@ -99,7 +100,7 @@ ml_d2i_RSA_PUBKEY (value s)
unsigned char *p;
RSA *r_key;
- p = String_val (s);
+ p = UString_val (s);
r_key = NULL;
if (! d2i_RSA_PUBKEY (&r_key, &p, caml_string_length (s)))
ml_crypto_error ("d2i_RSA_PUBKEY");
@@ -115,7 +116,7 @@ ml_d2i_PKCS8_RSA_PrivateKey (value s)
EVP_PKEY *e_key;
RSA *r_key;
- p = String_val (s);
+ p = UString_val (s);
p_key = NULL;
if (! d2i_PKCS8_PRIV_KEY_INFO (&p_key, &p, caml_string_length (s)))
ml_crypto_error ("d2i_PKCS8_PRIV_KEY_INFO");
@@ -156,8 +157,8 @@ ml_RSA_sign (value key, value d_type, va
{
unsigned int siglen;
if (! RSA_sign (NID_of_dtype (d_type),
- String_val (md), caml_string_length (md),
- String_val (sig), &siglen,
+ UString_val (md), caml_string_length (md),
+ UString_val (sig), &siglen,
RSA_val (key)))
ml_crypto_error ("RSA_sign");
return Val_int (siglen);
@@ -167,7 +168,7 @@ ml_RSA_verify (value key, value d_type,
ml_RSA_verify (value key, value d_type, value md, value sig)
{
return Val_bool (RSA_verify (NID_of_dtype (d_type),
- String_val (md), caml_string_length (md),
- String_val (sig), caml_string_length (sig),
+ UString_val (md), caml_string_length (md),
+ UString_val (sig), caml_string_length (sig),
RSA_val (key)));
}
============================================================
--- database-mt.ml 4f652fbc8f02cf793f9f61724fee5ce446e201b8
+++ database-mt.ml dc682bbab8f0c49c3feeccf09cb680b4d2f2e97b
@@ -42,7 +42,7 @@ let id_set_add_if t v s =
let bool_of_sql_string s = s <> "0"
let id_set_add_if t v s =
- if t then IdSet.add v s else s
+ if t && v <> "" then IdSet.add v s else s
let add_node id in_set rel_id rel nodes =
if id = "" then nodes else begin
@@ -50,7 +50,9 @@ let add_node id in_set rel_id rel nodes
try NodeMap.find id nodes
with Not_found ->
{ id = id ;
- kind = if in_set then REGULAR else NEIGHBOUR ;
+ kind = if in_set
+ then REGULAR
+ else (if rel = CHILD then NEIGHBOUR_IN else NEIGHBOUR_OUT) ;
family = [] } in
let new_node =
if rel_id <> "" && not (List.mem_assoc rel_id current_node.family)
@@ -123,6 +125,10 @@ let process_branching_edge_row g = funct
| _ -> g
+let fetch_children db id f init =
+ Sqlite3.fetch_f db (fun acc row -> f acc row.(0)) init
+ "SELECT child FROM revision_ancestry WHERE parent = '%s'" id
+
let fetch_agraph_with_view db query =
let agraph = Viz_types.empty_agraph in
@@ -159,6 +165,12 @@ let fetch_agraph_with_view db query =
view_name view_name
end in
+ (* reconnect disconnected components *)
+ let agraph =
+ if query = ALL
+ then agraph
+ else Components.reconnect (fetch_children db) agraph in
+
agraph
@@ -247,37 +259,24 @@ let spawn_monotone_diff db_fname monoton
"--revision=" ^ new_id ; "diff" ] in
if Viz_misc.debug "exec"
then Printf.eprintf "### exec: Running '%s'\n%!" (String.concat " " cmd) ;
- let error fmt =
- Printf.kprintf (fun s -> cb (`SUB_PROC_ERROR s)) fmt in
try
status#push "Running monotone ..." ;
Subprocess.spawn_out
- ~encoding:`LOCALE ~cmd
+ ~encoding:`NONE ~cmd
~reap_callback:status#pop
(fun ~exceptions ~stdout ~stderr status ->
- if status <> 0 then
- if List.exists
- (function
- | Glib.Convert.Error (Glib.Convert.ILLEGAL_SEQUENCE, _) -> true
- | _ -> false)
- exceptions
- then
- error
- begin
- let (is_utf8, _) = Glib.Convert.get_charset () in
- if is_utf8
- then format_of_string "Monotone output is not valid UTF-8"
- else format_of_string "Could not convert monotone output to UTF-8"
- end
- else
- if stderr = ""
- then
- error "Monotone exited with status %d:\n%s" status
- (String.concat "\n" (List.map Printexc.to_string exceptions))
- else
- error "Monotone error:\n%s" stderr
+ if status = 0
+ then
+ cb (`DIFF stdout)
else
- cb (`DIFF stdout))
+ let error fmt =
+ Printf.kprintf (fun s -> cb (`SUB_PROC_ERROR s)) fmt in
+ if stderr = ""
+ then
+ error "Monotone exited with status %d:\n%s" status
+ (String.concat "\n" (List.map Printexc.to_string exceptions))
+ else
+ error "Monotone error:\n%s" stderr)
with Gspawn.Error (_, msg) ->
Viz_types.errorf "Could not execute monotone:\n%s" msg
============================================================
--- mlsqlite/ocaml-sqlite3.c 4ffd05f56bd87954d1295b3b1fbd46e24de422cf
+++ mlsqlite/ocaml-sqlite3.c 6a916beee78d7ca2f9d9293703503409051b3e9c
@@ -510,7 +510,7 @@ ml_sqlite3_value_text (value v)
ml_sqlite3_value_text (value v)
{
SQLITE3_VALUE;
- return copy_string (sqlite3_value_text (val));
+ return copy_string ((char *) sqlite3_value_text (val));
}
#define MLTAG_INTEGER 0x2ddf233d
============================================================
--- q.ml cf55d43e61d6525f3b37d10d6c06136315130d14
+++ q.ml 98e2ccc98fc3aa19c76b4495b02ab545140383d0
@@ -1,18 +1,38 @@
-type 'a t = 'a list
+type 'a t = 'a list * 'a list
-let empty = []
+let norm f r =
+ if f = []
+ then List.rev r, []
+ else f, r
-let push q x =
- x :: q
+let empty = [], []
+let pop = function
+ | ([], r) ->
+ assert (r = []) ;
+ None
+ | (x :: f, r) ->
+ Some (x, norm f r)
+
+let push (f, r) x =
+ norm f (x :: r)
+
let push_list q l =
- List.rev_append l q
+ match q with
+ | ([], r) ->
+ assert (r = []) ;
+ (l, [])
+ | (f, r) ->
+ (f, List.rev_append l r)
-let concat q1 q2 =
- List.append q2 q1
+let concat (f1, r1) (f2, r2) =
+ (List.append f1 (List.rev_append r1 f2), r2)
-let to_list q =
- List.rev q
+let to_list (f, r) =
+ List.append f (List.rev r)
+let of_list l =
+ (l, [])
+
+let list_fold g l =
+ to_list (List.fold_left g empty l)
-let list_fold f l =
- to_list (List.fold_left f empty l)
============================================================
--- q.mli cad6dbc2092945f66504635d44bbb422a24439ec
+++ q.mli 511ce70836c714a8a1313eb984dcf7144f751e78
@@ -5,8 +5,10 @@ val push : 'a t -> 'a -> 'a t
val empty : 'a t
val push : 'a t -> 'a -> 'a t
+val pop : 'a t -> ('a * 'a t) option
val push_list : 'a t -> 'a list -> 'a t
val concat : 'a t -> 'a t -> 'a t
val to_list : 'a t -> 'a list
+val of_list : 'a list -> 'a t
val list_fold : ('a t -> 'b -> 'a t) -> 'b list -> 'a list
============================================================
--- ui.ml 7d827512c7a6b458a55372e159cfc7048e1ae789
+++ ui.ml 1f4fb2a2e62a329da2e0f41bbaff2551a46c22aa
@@ -335,6 +335,7 @@ let make w ~aa ~prefs =
~title:"Open a Monotone database" () in
dialog#add_button_stock `CLOSE `CLOSE ;
dialog#add_select_button_stock `OPEN `OPEN ;
+ ignore (dialog#connect#close (fun () -> dialog#response `CLOSE)) ;
dialog
end in
============================================================
--- unidiff.ml 50aa596af4116bc72ddd7fd6e05c030f91102881
+++ unidiff.ml 5b365e84428d582c26bc14e5ae1c4c3f7d62abea
@@ -105,7 +105,7 @@ let save_dialog parent text =
Viz_types.errorf "Could not write git diff output to '%s'" f)) ;
s
-let view_diff ?parent (junk_end, tags_coords) text =
+let view_diff ?parent (junk_end, tags_coords) text orig_text =
let window = GWindow.dialog
~no_separator:true ?parent
~title:"Git diff output"
@@ -114,7 +114,7 @@ let view_diff ?parent (junk_end, tags_co
window#add_button_stock `SAVE `SAVE ;
window#add_button_stock `CLOSE `CLOSE ;
window#set_default_response `CLOSE ;
- let s = lazy (save_dialog window text) in
+ let s = lazy (save_dialog window orig_text) in
ignore (window#connect#response (function
| `CLOSE | `DELETE_EVENT -> window#destroy ()
| `SAVE -> (Lazy.force s)#present () )) ;
@@ -167,10 +167,51 @@ let view_diff ?parent (junk_end, tags_co
window#misc#show ()
+
+let replacement_char = '\x7f' (* DEL *)
+let careful_convert_ascii o =
+ let s = String.copy o in
+ for i = 0 to String.length s - 1 do
+ if int_of_char s.[i] >= 0x80
+ then s.[i] <- replacement_char
+ done ;
+ s
+let careful_convert_utf8 o =
+ let s = String.copy o in
+ let len = String.length s in
+ let pos = ref 0 in
+ while !pos < len do
+ let prev_pos = !pos in
+ try ignore (Glib.Utf8.to_unichar_validated s ~pos)
+ with
+ | Glib.Convert.Error (Glib.Convert.ILLEGAL_SEQUENCE, _) ->
+ pos := prev_pos ;
+ s.[!pos] <- replacement_char ;
+ incr pos
+ | Glib.Convert.Error (Glib.Convert.PARTIAL_INPUT, _) ->
+ String.fill s prev_pos (len - prev_pos) replacement_char ;
+ pos := len
+ done ;
+ s
+
+let utf8ize =
+ let (is_utf8, _) = Glib.Convert.get_charset () in
+ if not is_utf8
+ then fun s ->
+ try Glib.Convert.locale_to_utf8 s
+ with Glib.Convert.Error _ ->
+ careful_convert_ascii s
+ else fun s ->
+ if Glib.Utf8.validate s
+ then s
+ else careful_convert_utf8 s
+
+
let view ~parent text =
let parent = GWindow.toplevel parent in
- try
- view_diff ?parent (analyze_diff_output text) text
+ try
+ let display_text = utf8ize text in
+ view_diff ?parent (analyze_diff_output display_text) display_text text
with Not_found ->
let d =
GWindow.message_dialog
============================================================
--- view.ml 69c88b304f62c440cbc49ec4c62a89a98a42da90
+++ view.ml 590a55ffdf7771966025cd399911f5761dd53658
@@ -2,17 +2,8 @@ open Revision_types
open Viz_types
open Revision_types
+let valid_utf8 = Glib.Utf8.validate
-let utf8ize =
- let fallback = "<binary data>" in
- let (is_utf8, _) = Glib.Convert.get_charset () in
- if not is_utf8
- then fun s ->
- try Glib.Convert.locale_to_utf8 s
- with Glib.Convert.Error _ -> fallback
- else fun s ->
- (if Glib.Utf8.validate s then s else fallback)
-
let wrap_in_scroll_window packing =
let sw = GBin.scrolled_window
~hpolicy:`AUTOMATIC
@@ -205,6 +196,7 @@ module Info_Display = struct
let r = GTree.cell_renderer_text [] in
column#pack r ;
column#add_attribute r "text" c_value ;
+ column#set_resizable true ;
ignore (view#append_column column)
end ;
begin
@@ -212,6 +204,7 @@ module Info_Display = struct
let r = GTree.cell_renderer_text [ `YALIGN 0. ] in
column#pack r ;
column#add_attribute r "text" c_signer ;
+ column#set_resizable true ;
ignore (view#append_column column)
end ;
view in
@@ -271,12 +264,13 @@ module Info_Display = struct
List.iter
(fun change ->
let text = text_of_delta_type change in
- if text <> "" then
+ (* monotone uses UTF-8 internaly *)
+ if valid_utf8 text && text <> "" then
let row = m#append ~parent () in
may
(m#set ~row ~column:i.revision_c_type)
(stock_of_delta_type change) ;
- m#set ~row ~column:i.revision_c_file (utf8ize text))
+ m#set ~row ~column:i.revision_c_file text)
change_set)
data.revision_set ;
i.revision_view#set_model (Some i.revision_model#coerce) ;
@@ -293,7 +287,12 @@ module Info_Display = struct
let row = m#append () in
let c_disp = String.capitalize c.c_name ^ ":" in
m#set ~row ~column:i.cert_c_name c_disp ;
- m#set ~row ~column:i.cert_c_value (utf8ize c.c_value) ;
+ (* cert values are either binary or valid utf8 *)
+ let c_value_disp =
+ if valid_utf8 c.c_value
+ then c.c_value
+ else "<binary data>" in
+ m#set ~row ~column:i.cert_c_value c_value_disp ;
m#set ~row ~column:i.cert_c_signer c.c_signer_id ;
m#set ~row ~column:i.cert_c_sig c.c_signature)
data.certs ;
@@ -390,7 +389,13 @@ module Branch_selector = struct
List.iter
(fun b ->
let row = model#append () in
- model#set ~row ~column (Glib.Markup.escape_text (utf8ize b)))
+ (* branch names are UTF-8 compatible *)
+ model#set ~row ~column
+ begin
+ if valid_utf8 b
+ then Glib.Markup.escape_text b
+ else "<i>invalid branch name</i>"
+ end)
br)
let set_branch { selector = s } b =
@@ -494,6 +499,11 @@ end
end
+let is_neighbor n =
+ match n.c_kind with
+ | NEIGHBOUR_IN | NEIGHBOUR_OUT -> true
+ | _ -> false
+
module Canvas = struct
@@ -698,7 +708,7 @@ module Canvas = struct
let x = node.n_w /. 2. in
let y = node.n_h /. 2. in
let props =
- if node.c_kind = NEIGHBOUR
+ if is_neighbor node
then `DASH (0., [| 5.; 5. |]) :: rect_props
else rect_props in
if node.c_kind = MERGE
@@ -710,7 +720,7 @@ module Canvas = struct
GnoCanvas.rect ~x1:(~-. x) ~y1:(~-. y) ~x2:x ~y2:y ~props g in
if node.c_kind = DISAPPROVE
then rect#affine_relative [| 0.5 ; 0.5 ; 0.5 ; -0.5 ; 0. ; 0. |] ;
- if node.c_kind = REGULAR || node.c_kind = NEIGHBOUR then
+ if node.c_kind = REGULAR || is_neighbor node then
begin
let scaled_font_size = font_size *. v.canvas.ppu in
let text = String.sub id 0 id_width in
@@ -734,7 +744,7 @@ module Canvas = struct
true
| _ ->
false end
- | `TWO_BUTTON_PRESS b when node.c_kind = NEIGHBOUR ->
+ | `TWO_BUTTON_PRESS b when is_neighbor node ->
if GdkEvent.Button.button b = 1 then begin
match Database.fetch_cert_value db id "branch" with
| other_branch :: _ ->
@@ -750,7 +760,8 @@ module Canvas = struct
match s.edge_kind with
SAME_BRANCH -> "black"
| BRANCHING -> "orange"
- | DISAPPROVED -> "red" in
+ | DISAPPROVED -> "red"
+ | SPANNING -> "darkgrey" in
let bpath = GnomeCanvas.PathDef.new_path () in
begin
GnomeCanvas.PathDef.moveto bpath s.controlp.(0) s.controlp.(1) ;
@@ -1008,6 +1019,8 @@ let open_db v fname branch =
let open_db v fname branch =
+ (* fname should be in filesystem encoding,
+ branch should be UTF-8 *)
close v ;
try
let db = Database.open_db fname in
============================================================
--- viz_misc.ml c0f7e882e80792536f5ec1e63695211c306a66e6
+++ viz_misc.ml 3480861e960d4f97092d197316e8032766a24b9e
@@ -135,7 +135,7 @@ let log kwd fmt =
let log kwd fmt =
Printf.kprintf
- (fun s -> if debug kwd then prerr_endline s)
+ (fun s -> if debug kwd then Printf.eprintf "### %s: %s\n%!" kwd s)
fmt
module Signal =
============================================================
--- viz_misc.mli 3a6714c41817a7f1c71d6852e4cc45b7c4962871
+++ viz_misc.mli 143f89f5d846cb9ed5603040321df691a98e33b1
@@ -26,7 +26,7 @@ val debug : string -> bool
val get_home_dir : unit -> string
val debug : string -> bool
-val log : string -> ('a, unit, string, unit) format4 -> 'a
+val log : string -> ('a, unit, string, unit) format4 -> 'a
module Signal :
sig
============================================================
--- viz_types.ml dbec817290ee9b0c728f86dd6a2a51cb323aaaa2
+++ viz_types.ml 81a02391285185725a67343f32a8f08fb8c94989
@@ -29,7 +29,8 @@ type node_kind =
type node_kind =
| REGULAR
- | NEIGHBOUR
+ | NEIGHBOUR_IN
+ | NEIGHBOUR_OUT
| MERGE
| DISAPPROVE
@@ -52,6 +53,7 @@ type edge_kind =
| BRANCHING
| SAME_BRANCH
| DISAPPROVED
+ | SPANNING
type agraph = {
nodes : a_node NodeMap.t ;
============================================================
--- viz_types.mli 0fb667537f24abfc4a2bc557ac00aeb1906830a1
+++ viz_types.mli 53b8aa3cf55af126fe3ce9b6e68ee43c139e2875
@@ -31,7 +31,8 @@ type node_kind =
type node_kind =
| REGULAR
- | NEIGHBOUR
+ | NEIGHBOUR_IN
+ | NEIGHBOUR_OUT
| MERGE
| DISAPPROVE
@@ -54,6 +55,7 @@ type edge_kind =
| BRANCHING
| SAME_BRANCH
| DISAPPROVED
+ | SPANNING
type agraph = {
nodes : a_node NodeMap.t ;