Attachment 765714 Details for Bug 769341 – git am-able patch for GTK3 switch

git am-able patch for GTK3 switch

0001-Unison-GTK3-switch-cf.-https-github.com-bcpierce00-u.patch (text/plain), 368.26 KB, created by Bernd Feige on 2022-02-23 15:28:08 UTC

(hide)

Description:

Filename:

MIME Type:

Creator: Bernd Feige

Created: 2022-02-23 15:28:08 UTC

Size: 368.26 KB

patch

obsolete

>From 5046106f2f9aa2a907290ad13aae755bd91c40dd Mon Sep 17 00:00:00 2001
>From: "Dr. Bernd Feige" <bernd.feige@uniklinik-freiburg.de>
>Date: Wed, 23 Feb 2022 16:04:45 +0100
>Subject: [PATCH] Unison GTK3 switch (cf.
> https://github.com/bcpierce00/unison/pull/566)
>
>---
> ...03565399de3a8e02e105eb2b8ee8cc620f19.patch | 26 +
> ...2e8f203f32510dfa292c99408928da974f4e.patch | 110 +
> ...711a6c6a4da4fb73fd6b81e1023710ee1266.patch | 645 ++
> ...5f073c0899d7e743582bdcad858bd2c69ea1.patch | 99 +
> ...57692b1e21517708e4252f3b0e22cb1ac206.patch | 8722 +++++++++++++++++
> net-misc/unison/unison-2.51.5.ebuild | 14 +-
> 6 files changed, 9613 insertions(+), 3 deletions(-)
> create mode 100644 net-misc/unison/files/393c03565399de3a8e02e105eb2b8ee8cc620f19.patch
> create mode 100644 net-misc/unison/files/62272e8f203f32510dfa292c99408928da974f4e.patch
> create mode 100644 net-misc/unison/files/9626711a6c6a4da4fb73fd6b81e1023710ee1266.patch
> create mode 100644 net-misc/unison/files/d0b45f073c0899d7e743582bdcad858bd2c69ea1.patch
> create mode 100644 net-misc/unison/files/e05957692b1e21517708e4252f3b0e22cb1ac206.patch
>
>diff --git a/net-misc/unison/files/393c03565399de3a8e02e105eb2b8ee8cc620f19.patch b/net-misc/unison/files/393c03565399de3a8e02e105eb2b8ee8cc620f19.patch
>new file mode 100644
>index 00000000000..78d2a689ad7
>--- /dev/null
>+++ b/net-misc/unison/files/393c03565399de3a8e02e105eb2b8ee8cc620f19.patch
>@@ -0,0 +1,26 @@
>+From 393c03565399de3a8e02e105eb2b8ee8cc620f19 Mon Sep 17 00:00:00 2001
>+From: =?UTF-8?q?T=C3=B5ivo=20Leedj=C3=A4rv?= <toivol@gmail.com>
>+Date: Mon, 17 Jan 2022 10:13:09 +0100
>+Subject: [PATCH] GHA: Fix building lablgtk on Windows
>+
>+---
>+ .github/workflows/CICD.yml | 6 ++++++
>+ 1 file changed, 6 insertions(+)
>+
>+diff --git a/.github/workflows/CICD.yml b/.github/workflows/CICD.yml
>+index 7aa71e71..740f6ecf 100644
>+--- a/.github/workflows/CICD.yml
>++++ b/.github/workflows/CICD.yml
>+@@ -134,6 +134,12 @@ jobs:
>+ echo %CYGWIN_ROOT_WRAPPERBIN%>> %GITHUB_PATH%
>+ echo SHELLOPTS=igncr>> %GITHUB_ENV%
>+ 
>++ - name: Prepare lablgtk install (Windows)
>++ if: ${{ runner.os == 'Windows' && contains(matrix.job.ocaml-version, '+mingw') }}
>++ run: |
>++ opam install opam-depext depext-cygwinports
>++ echo "/usr/${{ steps.vars.outputs.MinGW_ARCH }}-w64-mingw32/sys-root/mingw/bin" >> $GITHUB_PATH
>++
>+ - name: lablgtk install
>+ ## [2020-09] non-working/unavailable for MSVC or musl OCaml variants ; also, non-working for 32bit OCaml variant (see [GH:garrigue/lablgtk#64](https://github.com/garrigue/lablgtk/issues/64))
>+ if: ${{ ! ( contains(matrix.job.ocaml-version, '+msvc') || contains(matrix.job.ocaml-version, '+musl') || contains(matrix.job.ocaml-version, '+32bit') ) }}
>diff --git a/net-misc/unison/files/62272e8f203f32510dfa292c99408928da974f4e.patch b/net-misc/unison/files/62272e8f203f32510dfa292c99408928da974f4e.patch
>new file mode 100644
>index 00000000000..591482338a9
>--- /dev/null
>+++ b/net-misc/unison/files/62272e8f203f32510dfa292c99408928da974f4e.patch
>@@ -0,0 +1,110 @@
>+From 62272e8f203f32510dfa292c99408928da974f4e Mon Sep 17 00:00:00 2001
>+From: =?UTF-8?q?T=C3=B5ivo=20Leedj=C3=A4rv?=
>+ <69477666+tleedjarv@users.noreply.github.com>
>+Date: Wed, 14 Jul 2021 10:21:55 +0200
>+Subject: [PATCH] Replace statistics GtkCList with GtkTreeView
>+
>+CList has been deprecated and is removed in GTK3.
>+---
>+ src/uigtk2.ml | 74 +++++++++++++++++++++++++++++++--------------------
>+ 1 file changed, 45 insertions(+), 29 deletions(-)
>+
>+diff --git a/src/uigtk2.ml b/src/uigtk2.ml
>+index f8d73a23..f13c8522 100644
>+--- a/src/uigtk2.ml
>++++ b/src/uigtk2.ml
>+@@ -545,6 +545,17 @@ let rate2str v =
>+ " "
>+ end
>+ 
>++let mib = 1024. *. 1024.
>++let kib2str v =
>++ if v > 100_000_000. then
>++ Format.sprintf "%.0f MiB" (v /. mib)
>++ else if v > 1_000_000. then
>++ Format.sprintf "%.1f MiB" (v /. mib)
>++ else if v > 1024. then
>++ Format.sprintf "%.1f KiB" (v /. 1024.)
>++ else
>++ Format.sprintf "%.0f B" v
>++
>+ let statistics () =
>+ let title = "Statistics" in
>+ let t = GWindow.dialog ~title () in
>+@@ -559,22 +570,28 @@ let statistics () =
>+ let reception = new stats 320 50 in
>+ t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);
>+ 
>+- let lst =
>+- GList.clist
>+- ~packing:(t#vbox#add)
>+- ~titles_active:false
>+- ~titles:[""; "Client"; "Server"; "Total"] ()
>+- in
>+- lst#set_column ~auto_resize:true 0;
>+- lst#set_column ~auto_resize:true ~justification:`RIGHT 1;
>+- lst#set_column ~auto_resize:true ~justification:`RIGHT 2;
>+- lst#set_column ~auto_resize:true ~justification:`RIGHT 3;
>+- ignore (lst#append ["Reception rate"]);
>+- ignore (lst#append ["Data received"]);
>+- ignore (lst#append ["File data written"]);
>+- for r = 0 to 2 do
>+- lst#set_row ~selectable:false r
>+- done;
>++ let cols = new GTree.column_list in
>++ let c_1 = cols#add Gobject.Data.string in
>++ let c_client = cols#add Gobject.Data.string in
>++ let c_server = cols#add Gobject.Data.string in
>++ let c_total = cols#add Gobject.Data.string in
>++ let lst = GTree.list_store cols in
>++ let l = GTree.view ~model:lst ~enable_search:false ~packing:(t#vbox#add) () in
>++ l#selection#set_mode `NONE;
>++ ignore (l#append_column (GTree.view_column ~title:""
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_1]) ()));
>++ ignore (l#append_column (GTree.view_column ~title:"Client"
>++ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_client]) ()));
>++ ignore (l#append_column (GTree.view_column ~title:"Server"
>++ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_server]) ()));
>++ ignore (l#append_column (GTree.view_column ~title:"Total"
>++ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_total]) ()));
>++ let rate_row = lst#append () in
>++ ignore (lst#set rate_row c_1 "Reception rate");
>++ let receive_row = lst#append () in
>++ ignore (lst#set receive_row c_1 "Data received");
>++ let data_row = lst#append () in
>++ ignore (lst#set data_row c_1 "File data written");
>+ 
>+ ignore (t#event#connect#map ~callback:(fun _ ->
>+ emission#activate true;
>+@@ -597,19 +614,18 @@ let statistics () =
>+ let stopCounter = ref 0 in
>+ 
>+ let updateTable () =
>+- let kib2str v = Format.sprintf "%.0f B" v in
>+- lst#set_cell ~text:(rate2str !receiveRate2) 0 1;
>+- lst#set_cell ~text:(rate2str !emitRate2) 0 2;
>+- lst#set_cell ~text:
>+- (rate2str (!receiveRate2 +. !emitRate2)) 0 3;
>+- lst#set_cell ~text:(kib2str !receivedBytes) 1 1;
>+- lst#set_cell ~text:(kib2str !emittedBytes) 1 2;
>+- lst#set_cell ~text:
>+- (kib2str (!receivedBytes +. !emittedBytes)) 1 3;
>+- lst#set_cell ~text:(kib2str !clientWritten) 2 1;
>+- lst#set_cell ~text:(kib2str !serverWritten) 2 2;
>+- lst#set_cell ~text:
>+- (kib2str (!clientWritten +. !serverWritten)) 2 3
>++ let row = rate_row in
>++ lst#set ~row ~column:c_client (rate2str !receiveRate2);
>++ lst#set ~row ~column:c_server (rate2str !emitRate2);
>++ lst#set ~row ~column:c_total (rate2str (!receiveRate2 +. !emitRate2));
>++ let row = receive_row in
>++ lst#set ~row ~column:c_client (kib2str !receivedBytes);
>++ lst#set ~row ~column:c_server (kib2str !emittedBytes);
>++ lst#set ~row ~column:c_total (kib2str (!receivedBytes +. !emittedBytes));
>++ let row = data_row in
>++ lst#set ~row ~column:c_client (kib2str !clientWritten);
>++ lst#set ~row ~column:c_server (kib2str !serverWritten);
>++ lst#set ~row ~column:c_total (kib2str (!clientWritten +. !serverWritten))
>+ in
>+ let timeout _ =
>+ emitRate :=
>diff --git a/net-misc/unison/files/9626711a6c6a4da4fb73fd6b81e1023710ee1266.patch b/net-misc/unison/files/9626711a6c6a4da4fb73fd6b81e1023710ee1266.patch
>new file mode 100644
>index 00000000000..593ed5eea05
>--- /dev/null
>+++ b/net-misc/unison/files/9626711a6c6a4da4fb73fd6b81e1023710ee1266.patch
>@@ -0,0 +1,645 @@
>+From 9626711a6c6a4da4fb73fd6b81e1023710ee1266 Mon Sep 17 00:00:00 2001
>+From: =?UTF-8?q?T=C3=B5ivo=20Leedj=C3=A4rv?=
>+ <69477666+tleedjarv@users.noreply.github.com>
>+Date: Wed, 14 Jul 2021 15:39:42 +0200
>+Subject: [PATCH] uigtk2: Compile with lablgtk3
>+
>+Just the minimal changes to make uigtk2 compile with lablgtk3.
>+
>+Main changes:
>+
>+ * Replaced custom busy mouse pointer (pixmaps no more) with stock busy
>+ pointer
>+ * Removed `no_separator` from all windows and dialogs (removed in GTK)
>+ * Replaced `allow_grow` (removed in GTK) with `resizable` for all
>+ windows and dialogs
>+ * Replaced `image_menu_item` (removed in GTK) with `menu_item`
>+ * Replaced `GWindow.file_selection` dialog for getting roots with
>+ `GFile.chooser_button`
>+ * Replaced `option_menu` (removed in GTK) in documentation window with
>+ regular `menu_bar` (just a workaround)
>+ * Replaced toolbar `insert_button` (removed in GTK) with new toolbar
>+ API (`GButton.tool_button` and friends)
>+
>+Limitations:
>+
>+ * Statistics window is currently lacking diagram graphics (pixmaps no
>+ more)
>+ * `set_size_chars` seems to be broken, making sizes of many widgets
>+ incorrect
>+---
>+ .github/workflows/CICD.yml | 2 +-
>+ src/Makefile.OCaml | 10 +-
>+ src/dune | 2 +-
>+ src/pixmaps.ml | 17 ----
>+ src/uigtk2.ml | 194 +++++++++++++++++--------------------
>+ unison.opam | 3 +-
>+ 6 files changed, 99 insertions(+), 129 deletions(-)
>+
>+diff --git a/.github/workflows/CICD.yml b/.github/workflows/CICD.yml
>+index 740f6ecf6..691016a00 100644
>+--- a/.github/workflows/CICD.yml
>++++ b/.github/workflows/CICD.yml
>+@@ -143,7 +143,7 @@ jobs:
>+ - name: lablgtk install
>+ ## [2020-09] non-working/unavailable for MSVC or musl OCaml variants ; also, non-working for 32bit OCaml variant (see [GH:garrigue/lablgtk#64](https://github.com/garrigue/lablgtk/issues/64))
>+ if: ${{ ! ( contains(matrix.job.ocaml-version, '+msvc') || contains(matrix.job.ocaml-version, '+musl') || contains(matrix.job.ocaml-version, '+32bit') ) }}
>+- run: opam depext --install --verbose --yes lablgtk
>++ run: opam depext --install --verbose --yes lablgtk3 && opam install ocamlfind
>+ 
>+ - shell: bash
>+ run: |
>+diff --git a/src/Makefile.OCaml b/src/Makefile.OCaml
>+index 821ce8a6d..2a4afba53 100644
>+--- a/src/Makefile.OCaml
>++++ b/src/Makefile.OCaml
>+@@ -73,7 +73,7 @@ OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | tr '\\' '/' | tr -
>+ # This should be set to an appropriate value automatically, depending
>+ # on whether the lablgtk library is available
>+ LABLGTKLIB=$(OCAMLLIBDIR)/lablgtk
>+-LABLGTK2LIB=$(OCAMLLIBDIR)/lablgtk2
>++LABLGTK2LIB=$(OCAMLLIBDIR)/lablgtk3
>+ ##BCP [3/2007]: Removed temporarily, since the OSX UI is not working well
>+ ## at the moment and we don't want to confuse people by building it by default
>+ ifeq ($(OSARCH),osx)
>+@@ -82,7 +82,7 @@ else
>+ ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB))
>+ UISTYLE=gtk2
>+ else
>+- LABLGTK2LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk2)
>++ LABLGTK2LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk3)
>+ ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB))
>+ UISTYLE=gtk2
>+ else
>+@@ -294,12 +294,12 @@ OCAMLFIND := $(shell command -v ocamlfind 2> /dev/null)
>+ 
>+ ifeq ($(UISTYLE), gtk2)
>+ ifndef OCAMLFIND
>+- CAMLFLAGS+=-I +lablgtk2
>++ CAMLFLAGS+=-I +lablgtk3
>+ else
>+- CAMLFLAGS+=$(shell $(OCAMLFIND) query -i-format lablgtk2 )
>++ CAMLFLAGS+=$(shell $(OCAMLFIND) query -i-format lablgtk3 )
>+ endif
>+ OCAMLOBJS+=pixmaps.cmo uigtk2.cmo linkgtk2.cmo
>+- OCAMLLIBS+=lablgtk.cma
>++ OCAMLLIBS+=lablgtk3.cma
>+ endif
>+ 
>+ ########################################################################
>+diff --git a/src/dune b/src/dune
>+index e5cd45a92..cdc4404fe 100644
>+--- a/src/dune
>++++ b/src/dune
>+@@ -26,4 +26,4 @@
>+ (public_name unison-gtk2)
>+ (flags :standard -w -3-6-9-27-32-52)
>+ (modules linkgtk2 uigtk2)
>+- (libraries threads unison_lib lablgtk2))
>++ (libraries threads unison_lib lablgtk3))
>+diff --git a/src/pixmaps.ml b/src/pixmaps.ml
>+index 857995ffd..1eeb21351 100644
>+--- a/src/pixmaps.ml
>++++ b/src/pixmaps.ml
>+@@ -251,23 +251,6 @@ let copyBAblack_asym = [|
>+ "............................"
>+ |]
>+ 
>+-(***********************************************************************)
>+-(* Busy-Interactive mous pointer *)
>+-(***********************************************************************)
>+-
>+-let left_ptr_watch = "\
>+-\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\
>+-\x0c\x00\x00\x00\x1c\x00\x00\x00\x3c\x00\x00\x00\
>+-\x7c\x00\x00\x00\xfc\x00\x00\x00\xfc\x01\x00\x00\
>+-\xfc\x3b\x00\x00\x7c\x38\x00\x00\x6c\x54\x00\x00\
>+-\xc4\xdc\x00\x00\xc0\x44\x00\x00\x80\x39\x00\x00\
>+-\x80\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
>+-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
>+-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
>+-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
>+-\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\
>+-\x00\x00\x00\x00\x00\x00\x00\x00"
>+-
>+ 
>+ (***********************************************************************)
>+ (* Unison icon *)
>+diff --git a/src/uigtk2.ml b/src/uigtk2.ml
>+index f13c85224..e09e0275a 100644
>+--- a/src/uigtk2.ml
>++++ b/src/uigtk2.ml
>+@@ -100,15 +100,7 @@ let icon =
>+ p
>+ 
>+ let leftPtrWatch =
>+- lazy
>+- (let bitmap =
>+- Gdk.Bitmap.create_from_data
>+- ~width:32 ~height:32 Pixmaps.left_ptr_watch
>+- in
>+- let color =
>+- Gdk.Color.alloc ~colormap:(Gdk.Color.get_system_colormap ()) `BLACK in
>+- Gdk.Cursor.create_from_pixmap
>+- (bitmap :> Gdk.pixmap) ~mask:bitmap ~fg:color ~bg:color ~x:2 ~y:2)
>++ lazy (Gdk.Cursor.create `WATCH)
>+ 
>+ let make_busy w =
>+ if Util.osType <> `Win32 then
>+@@ -306,8 +298,8 @@ let primaryText msg =
>+ chosen, false if the second button is chosen. *)
>+ let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message =
>+ let t =
>+- GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true
>+- ~allow_grow:false () in
>++ GWindow.dialog ~parent ~border_width:6 ~modal:true
>++ ~resizable:false () in
>+ t#vbox#set_spacing 12;
>+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+ ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG
>+@@ -353,7 +345,7 @@ let warnBox ~parent title message =
>+ (* In batch mode, just pop up a window and go ahead *)
>+ let t =
>+ GWindow.dialog ~parent
>+- ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in
>++ ~border_width:6 ~modal:true ~resizable:false () in
>+ t#vbox#set_spacing 12;
>+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+ ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
>+@@ -413,20 +405,21 @@ class ['a] gMenuFactory
>+ item
>+ method add_image_item ?(image : GObj.widget option)
>+ ?modi ?key ?callback ?stock ?name label =
>++ (* GTK 3 does not provide image menu items (there is a way to
>++ manually create a workaround but that does not work with
>++ lablgtk. Let's create a regular menu item instead. *)
>+ let item =
>+- GMenu.image_menu_item ~use_mnemonic:true ?image ~label ?stock () in
>++ GMenu.menu_item ~use_mnemonic:true ~label () in
>+ match stock with
>+ | None ->
>+- self#bind ?modi ?key ?callback label ?name
>+- (item : GMenu.image_menu_item :> GMenu.menu_item);
>++ self#bind ?modi ?key ?callback label ?name item;
>+ item
>+ | Some s ->
>+ try
>+ let st = GtkStock.Item.lookup s in
>+ self#bind
>+ ?modi ?key:(if st.GtkStock.keyval=0 then key else None)
>+- ?callback label ?name
>+- (item : GMenu.image_menu_item :> GMenu.menu_item);
>++ ?callback label ?name item;
>+ item
>+ with Not_found -> item
>+ 
>+@@ -449,7 +442,7 @@ end
>+ HIGHER-LEVEL WIDGETS
>+ ***********************************************************************)
>+ 
>+-class stats width height =
>++(*class stats width height =
>+ let pixmap = GDraw.pixmap ~width ~height () in
>+ let area =
>+ pixmap#set_foreground `WHITE;
>+@@ -522,7 +515,7 @@ class stats width height =
>+ area#misc#draw None
>+ end
>+ end
>+-
>++*)
>+ let clientWritten = ref 0.
>+ let serverWritten = ref 0.
>+ let emitRate2 = ref 0.
>+@@ -565,10 +558,10 @@ let statistics () =
>+ ignore (t_dismiss#connect#clicked ~callback:dismiss);
>+ ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));
>+ 
>+- let emission = new stats 320 50 in
>++(* let emission = new stats 320 50 in
>+ t#vbox#pack ~expand:false ~padding:4 (emission :> GObj.widget);
>+ let reception = new stats 320 50 in
>+- t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);
>++ t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);*)
>+ 
>+ let cols = new GTree.column_list in
>+ let c_1 = cols#add Gobject.Data.string in
>+@@ -592,7 +585,7 @@ let statistics () =
>+ ignore (lst#set receive_row c_1 "Data received");
>+ let data_row = lst#append () in
>+ ignore (lst#set data_row c_1 "File data written");
>+-
>++(*
>+ ignore (t#event#connect#map ~callback:(fun _ ->
>+ emission#activate true;
>+ reception#activate true;
>+@@ -600,7 +593,7 @@ let statistics () =
>+ ignore (t#event#connect#unmap ~callback:(fun _ ->
>+ emission#activate false;
>+ reception#activate false;
>+- false));
>++ false));*)
>+ 
>+ let delay = 0.5 in
>+ let a = 0.5 in
>+@@ -634,14 +627,14 @@ let statistics () =
>+ emitRate2 :=
>+ b *. !emitRate2 +.
>+ (1. -. b) *. (!Remote.emittedBytes -. !emittedBytes) /. delay;
>+- emission#push !emitRate;
>++(* emission#push !emitRate;*)
>+ receiveRate :=
>+ a *. !receiveRate +.
>+ (1. -. a) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;
>+ receiveRate2 :=
>+ b *. !receiveRate2 +.
>+ (1. -. b) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;
>+- reception#push !receiveRate;
>++(* reception#push !receiveRate;*)
>+ emittedBytes := !Remote.emittedBytes;
>+ receivedBytes := !Remote.receivedBytes;
>+ if !stopCounter > 0 then decr stopCounter;
>+@@ -664,21 +657,6 @@ let statistics () =
>+ let stopStats () = stopCounter := 10 in
>+ (t, startStats, stopStats)
>+ 
>+-(****)
>+-
>+-(* Standard file dialog *)
>+-let file_dialog ~parent ~title ~callback ?filename () =
>+- let sel = GWindow.file_selection ~parent ~title ~modal:true ?filename () in
>+- ignore (sel#cancel_button#connect#clicked ~callback:sel#destroy);
>+- ignore (sel#ok_button#connect#clicked ~callback:
>+- (fun () ->
>+- let name = sel#filename in
>+- sel#destroy ();
>+- callback name));
>+- sel#show ();
>+- ignore (sel#connect#destroy ~callback:GMain.Main.quit);
>+- GMain.Main.main ()
>+-
>+ (* ------ *)
>+ 
>+ let fatalError message =
>+@@ -688,7 +666,7 @@ let fatalError message =
>+ let title = "Fatal error" in
>+ let t =
>+ GWindow.dialog ~parent:(toplevelWindow ())
>+- ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in
>++ ~border_width:6 ~modal:true ~resizable:false () in
>+ t#vbox#set_spacing 12;
>+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+ ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG
>+@@ -711,7 +689,7 @@ let tryAgainOrQuit = fatalError
>+ 
>+ let getFirstRoot () =
>+ let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
>+- ~modal:true ~allow_grow:true () in
>++ ~modal:true ~resizable:true () in
>+ t#misc#grab_focus ();
>+ 
>+ let hb = GPack.hbox
>+@@ -725,12 +703,14 @@ let getFirstRoot () =
>+ ignore (GMisc.label ~text:"Dir:" ~packing:(f1#pack ~expand:false) ());
>+ let fileE = GEdit.entry ~packing:f1#add () in
>+ fileE#misc#grab_focus ();
>+- let browseCommand() =
>+- file_dialog ~parent:t ~title:"Select a local directory"
>+- ~callback:fileE#set_text ~filename:fileE#text () in
>+- let b = GButton.button ~label:"Browse"
>+- ~packing:(f1#pack ~expand:false) () in
>+- ignore (b#connect#clicked ~callback:browseCommand);
>++ let b = GFile.chooser_button ~action:`SELECT_FOLDER
>++ ~title:"Select a local directory"
>++ ~packing:(f1#pack ~expand:false) () in
>++ ignore (b#connect#selection_changed ~callback:(fun () ->
>++ if not fileE#is_focus then
>++ fileE#set_text (match b#filename with None -> "" | Some s -> s)));
>++ ignore (fileE#connect#changed ~callback:(fun () ->
>++ if fileE#is_focus then ignore (b#set_filename fileE#text)));
>+ 
>+ let f3 = t#action_area in
>+ let result = ref None in
>+@@ -755,7 +735,7 @@ let getFirstRoot () =
>+ 
>+ let getSecondRoot () =
>+ let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
>+- ~modal:true ~allow_grow:true () in
>++ ~modal:true ~resizable:true () in
>+ t#misc#grab_focus ();
>+ 
>+ let message = "Please enter the second directory you want to synchronize." in
>+@@ -778,12 +758,14 @@ let getSecondRoot () =
>+ ignore (GMisc.label ~text:"Directory:" ~packing:(f1#pack ~expand:false) ());
>+ let fileE = GEdit.entry ~packing:f1#add () in
>+ fileE#misc#grab_focus ();
>+- let browseCommand() =
>+- file_dialog ~parent:t ~title:"Select a local directory"
>+- ~callback:fileE#set_text ~filename:fileE#text () in
>+- let b = GButton.button ~label:"Browse"
>+- ~packing:(f1#pack ~expand:false) () in
>+- ignore (b#connect#clicked ~callback:browseCommand);
>++ let b = GFile.chooser_button ~action:`SELECT_FOLDER
>++ ~title:"Select a local directory"
>++ ~packing:(f1#pack ~expand:false) () in
>++ ignore (b#connect#selection_changed ~callback:(fun () ->
>++ if not fileE#is_focus then
>++ fileE#set_text (match b#filename with None -> "" | Some s -> s)));
>++ ignore (fileE#connect#changed ~callback:(fun () ->
>++ if fileE#is_focus then ignore (b#set_filename fileE#text)));
>+ 
>+ let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in
>+ let localB = GButton.radio_button ~packing:(f0#pack ~expand:false)
>+@@ -886,7 +868,7 @@ let getPassword rootName msg =
>+ let t =
>+ GWindow.dialog ~parent:(toplevelWindow ())
>+ ~title:"Unison: SSH connection" ~position:`CENTER
>+- ~no_separator:true ~modal:true ~allow_grow:false ~border_width:6 () in
>++ ~modal:true ~resizable:false ~border_width:6 () in
>+ t#misc#grab_focus ();
>+ 
>+ t#vbox#set_spacing 12;
>+@@ -1078,7 +1060,7 @@ let createProfile parent =
>+ GMisc.label
>+ ~xpad:12 ~ypad:12
>+ ~text:"Welcome to the Unison Profile Creation Assistant.\n\n\
>+- Click \"Forward\" to begin."
>++ Click \"Next\" to begin."
>+ () in
>+ ignore
>+ (assistant#append_page
>+@@ -1595,7 +1577,7 @@ let defaultValue t =
>+ let editPreference parent nm ty vl =
>+ let t =
>+ GWindow.dialog ~parent ~border_width:12
>+- ~no_separator:true ~title:"Edit the Preference"
>++ ~title:"Edit the Preference"
>+ ~modal:true () in
>+ let vb = t#vbox in
>+ vb#set_spacing 6;
>+@@ -1946,7 +1928,7 @@ let documentPreference ~compact ~packing =
>+ let addPreference parent =
>+ let t =
>+ GWindow.dialog ~parent ~border_width:12
>+- ~no_separator:true ~title:"Add a Preference"
>++ ~title:"Add a Preference"
>+ ~modal:true () in
>+ let vb = t#vbox in
>+ (* vb#set_spacing 18;*)
>+@@ -2048,7 +2030,7 @@ let addPreference parent =
>+ let editProfile parent name =
>+ let t =
>+ GWindow.dialog ~parent ~border_width:12
>+- ~no_separator:true ~title:(Format.sprintf "%s - Profile Editor" name)
>++ ~title:(Format.sprintf "%s - Profile Editor" name)
>+ ~modal:true () in
>+ let vb = t#vbox in
>+ (* t#vbox#set_spacing 18;*)
>+@@ -2299,7 +2281,7 @@ let getProfile quit =
>+ (* Build the dialog *)
>+ let t =
>+ GWindow.dialog ~parent:(toplevelWindow ()) ~border_width:12
>+- ~no_separator:true ~title:"Profile Selection"
>++ ~title:"Profile Selection"
>+ ~modal:true () in
>+ t#set_default_width 550;
>+ 
>+@@ -2479,18 +2461,22 @@ let documentation sect =
>+ 
>+ let (name, docstr) = Safelist.assoc sect Strings.docs in
>+ let hb = GPack.hbox ~packing:(t#vbox#pack ~expand:false ~padding:2) () in
>+- let optionmenu =
>+- GMenu.option_menu ~packing:(hb#pack ~expand:true ~fill:false) () in
>+ 
>+ let t_text =
>+ new scrolled_text ~editable:false
>+- ~width:80 ~height:20 ~packing:t#vbox#add ()
>++ ~width:80 ~height:20 ~packing:(t#vbox#pack ~expand:true) ()
>+ in
>+ t_text#insert docstr;
>+ 
>++ let menuBar =
>++ GMenu.menu_bar ~border_width:0
>++ ~packing:(hb#pack ~expand:true ~fill:false) () in
>++ let mi = GMenu.menu_item ~label:"Topics" () in
>++ menuBar#insert mi 0;
>++
>+ let sect_idx = ref 0 in
>+ let idx = ref 0 in
>+- let menu = GMenu.menu () in
>++ let menu = GMenu.menu ~packing:(mi#set_submenu) () in
>+ let addDocSection (shortname, (name, docstr)) =
>+ if shortname <> "" && name <> "" then begin
>+ if shortname = sect then sect_idx := !idx;
>+@@ -2501,8 +2487,6 @@ let documentation sect =
>+ end
>+ in
>+ Safelist.iter addDocSection Strings.docs;
>+- optionmenu#set_menu menu;
>+- optionmenu#set_history !sect_idx;
>+ 
>+ t#show ()
>+ 
>+@@ -2529,8 +2513,8 @@ let messageBox ~title ?(action = fun t -> t#destroy) message =
>+ let twoBoxAdvanced
>+ ~parent ~title ~message ~longtext ~advLabel ~astock ~bstock =
>+ let t =
>+- GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true
>+- ~allow_grow:false () in
>++ GWindow.dialog ~parent ~border_width:6 ~modal:true
>++ ~resizable:false () in
>+ t#vbox#set_spacing 12;
>+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+ ignore (GMisc.image ~stock:`DIALOG_QUESTION ~icon_size:`DIALOG
>+@@ -2562,8 +2546,8 @@ let twoBoxAdvanced
>+ 
>+ let summaryBox ~parent ~title ~message ~f =
>+ let t =
>+- GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true
>+- ~allow_grow:false ~focus_on_map:false () in
>++ GWindow.dialog ~parent ~border_width:6 ~modal:true
>++ ~resizable:false ~focus_on_map:false () in
>+ t#vbox#set_spacing 12;
>+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+ ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
>+@@ -2692,13 +2676,12 @@ let createToplevelWindow () =
>+ Action bar
>+ *********************************************************************)
>+ let actionBar =
>+- let hb = GBin.handle_box ~packing:(toplevelVBox#pack ~expand:false) () in
>+ GButton.toolbar ~style:`BOTH
>+ (* 2003-0519 (stse): how to set space size in gtk 2.0? *)
>+ (* Answer from Jacques Garrigue: this can only be done in
>+ the user's.gtkrc, not programmatically *)
>+- ~orientation:`HORIZONTAL ~tooltips:true (* ~space_size:10 *)
>+- ~packing:(hb#add) () in
>++ ~orientation:`HORIZONTAL (* ~space_size:10 *)
>++ ~packing:(toplevelVBox#pack ~expand:false) () in
>+ 
>+ (*********************************************************************
>+ Create the main window
>+@@ -2949,6 +2932,7 @@ let createToplevelWindow () =
>+ GRange.progress_bar ~packing:(statusHBox#pack ~expand:false) () in
>+ 
>+ progressBar#misc#set_size_chars ~height:1 ~width:28 ();
>++ progressBar#set_show_text true;
>+ progressBar#set_pulse_step 0.02;
>+ let progressBarPulse = ref false in
>+ 
>+@@ -3624,7 +3608,7 @@ let createToplevelWindow () =
>+ ~title:"Synchronization summary" ~message ~f:
>+ (fun t ->
>+ let bullet = "\xe2\x80\xa2 " in
>+- let layout = t#misc#pango_context#create_layout in
>++ let layout = Pango.Layout.create t#misc#pango_context#as_context in
>+ Pango.Layout.set_text layout bullet;
>+ let (n, _) = Pango.Layout.get_pixel_size layout in
>+ let path =
>+@@ -3690,35 +3674,39 @@ let createToplevelWindow () =
>+ let questionAction _ = doAction (fun _ diff -> diff.direction <- Conflict "") in
>+ let mergeAction _ = doAction (fun _ diff -> diff.direction <- Merge) in
>+ 
>++ let insert_button (toolbar : #GButton.toolbar) ~stock ~text ~tooltip ~callback () =
>++ let b = GButton.tool_button ~stock ~label:text ~packing:toolbar#insert () in
>++ ignore (b#connect#clicked ~callback);
>++ b#misc#set_tooltip_text tooltip;
>++ b
>++ in
>++
>+ (* actionBar#insert_space ();*)
>+ grAdd grAction
>+- (actionBar#insert_button
>+-(* ~icon:((GMisc.pixmap rightArrowBlack ())#coerce)*)
>+- ~icon:((GMisc.image ~stock:`GO_FORWARD ())#coerce)
>++ (insert_button actionBar
>++ ~stock:`GO_FORWARD
>+ ~text:"Left to Right"
>+ ~tooltip:"Propagate selected items\n\
>+ from the left replica to the right one"
>+ ~callback:rightAction ());
>+ (* actionBar#insert_space ();*)
>+ grAdd grAction
>+- (actionBar#insert_button ~text:"Skip"
>+- ~icon:((GMisc.image ~stock:`NO ())#coerce)
>++ (insert_button actionBar ~text:"Skip"
>++ ~stock:`NO
>+ ~tooltip:"Skip selected items"
>+ ~callback:questionAction ());
>+ (* actionBar#insert_space ();*)
>+ grAdd grAction
>+- (actionBar#insert_button
>+-(* ~icon:((GMisc.pixmap leftArrowBlack ())#coerce)*)
>+- ~icon:((GMisc.image ~stock:`GO_BACK ())#coerce)
>++ (insert_button actionBar
>++ ~stock:`GO_BACK
>+ ~text:"Right to Left"
>+ ~tooltip:"Propagate selected items\n\
>+ from the right replica to the left one"
>+ ~callback:leftAction ());
>+ (* actionBar#insert_space ();*)
>+ grAdd grAction
>+- (actionBar#insert_button
>+-(* ~icon:((GMisc.pixmap mergeLogoBlack())#coerce)*)
>+- ~icon:((GMisc.image ~stock:`ADD ())#coerce)
>++ (insert_button actionBar
>++ ~stock:`ADD
>+ ~text:"Merge"
>+ ~tooltip:"Merge selected files"
>+ ~callback:mergeAction ());
>+@@ -3751,9 +3739,9 @@ let createToplevelWindow () =
>+ | None ->
>+ () in
>+ 
>+- actionBar#insert_space ();
>+- grAdd grDiff (actionBar#insert_button ~text:"Diff"
>+- ~icon:((GMisc.image ~stock:`DIALOG_INFO ())#coerce)
>++ actionBar#insert (GButton.separator_tool_item ());
>++ grAdd grDiff (insert_button actionBar ~text:"Diff"
>++ ~stock:`DIALOG_INFO
>+ ~tooltip:"Compare the two files at each replica"
>+ ~callback:diffCmd ());
>+ 
>+@@ -3761,8 +3749,8 @@ let createToplevelWindow () =
>+ Detail button
>+ *********************************************************************)
>+ (* actionBar#insert_space ();*)
>+- grAdd grDetail (actionBar#insert_button ~text:"Details"
>+- ~icon:((GMisc.image ~stock:`INFO ())#coerce)
>++ grAdd grDetail (insert_button actionBar ~text:"Details"
>++ ~stock:`INFO
>+ ~tooltip:"Show detailed information about\n\
>+ an item, when available"
>+ ~callback:showDetCommand ());
>+@@ -3780,11 +3768,11 @@ let createToplevelWindow () =
>+ (*********************************************************************
>+ go button
>+ *********************************************************************)
>+- actionBar#insert_space ();
>++ actionBar#insert (GButton.separator_tool_item ());
>+ grAdd grGo
>+- (actionBar#insert_button ~text:"Go"
>++ (insert_button actionBar ~text:"Go"
>+ (* tooltip:"Go with displayed actions" *)
>+- ~icon:((GMisc.image ~stock:`EXECUTE ())#coerce)
>++ ~stock:`EXECUTE
>+ ~tooltip:"Perform the synchronization"
>+ ~callback:(fun () ->
>+ getLock synchronize) ());
>+@@ -3843,22 +3831,22 @@ let createToplevelWindow () =
>+ in
>+ (* actionBar#insert_space ();*)
>+ grAdd grRescan
>+- (actionBar#insert_button ~text:"Rescan"
>+- ~icon:((GMisc.image ~stock:`REFRESH ())#coerce)
>++ (insert_button actionBar ~text:"Rescan"
>++ ~stock:`REFRESH
>+ ~tooltip:"Check for updates"
>+ ~callback: (fun () -> reloadProfile(); detectCmd()) ());
>+ 
>+ (*********************************************************************
>+ Profile change button
>+ *********************************************************************)
>+- actionBar#insert_space ();
>++ actionBar#insert (GButton.separator_tool_item ());
>+ let profileChange _ =
>+ match getProfile false with
>+ None -> ()
>+ | Some p -> clearMainWindow (); loadProfile p false; detectCmd ()
>+ in
>+- grAdd grRescan (actionBar#insert_button ~text:"Change Profile"
>+- ~icon:((GMisc.image ~stock:`OPEN ())#coerce)
>++ grAdd grRescan (insert_button actionBar ~text:"Change Profile"
>++ ~stock:`OPEN
>+ ~tooltip:"Select a different profile"
>+ ~callback:profileChange ());
>+ 
>+@@ -4120,11 +4108,9 @@ let createToplevelWindow () =
>+ let (expertMenu, _) = add_submenu "Expert" in
>+ 
>+ let addDebugToggle modname =
>+- let cm =
>+- expertMenu#add_check_item ~active:(Trace.enabled modname)
>+- ~callback:(fun b -> Trace.enable modname b)
>+- ("Debug '" ^ modname ^ "'") in
>+- cm#set_show_toggle true in
>++ ignore (expertMenu#add_check_item ~active:(Trace.enabled modname)
>++ ~callback:(fun b -> Trace.enable modname b)
>++ ("Debug '" ^ modname ^ "'")) in
>+ 
>+ addDebugToggle "all";
>+ addDebugToggle "verbose";
>+diff --git a/unison.opam b/unison.opam
>+index 172c81d29..df2ef5315 100644
>+--- a/unison.opam
>++++ b/unison.opam
>+@@ -12,8 +12,9 @@ dev-repo: "git://github.com/bcpierce00/unison.git"
>+ build: ["dune" "build" "-p" name "-j" jobs]
>+ depends: [
>+ "ocaml" {>= "4.03"}
>++ "ocamlfind" {build}
>+ "dune" {>= "2.3"}
>+- "lablgtk" {>= "2.18.6"}
>++ "lablgtk3" {>= "3.1.0"}
>+ ]
>+ synopsis: "File-synchronization tool for Unix and Windows"
>+ description: """
>diff --git a/net-misc/unison/files/d0b45f073c0899d7e743582bdcad858bd2c69ea1.patch b/net-misc/unison/files/d0b45f073c0899d7e743582bdcad858bd2c69ea1.patch
>new file mode 100644
>index 00000000000..a3b09528c31
>--- /dev/null
>+++ b/net-misc/unison/files/d0b45f073c0899d7e743582bdcad858bd2c69ea1.patch
>@@ -0,0 +1,99 @@
>+From d0b45f073c0899d7e743582bdcad858bd2c69ea1 Mon Sep 17 00:00:00 2001
>+From: =?UTF-8?q?T=C3=B5ivo=20Leedj=C3=A4rv?=
>+ <69477666+tleedjarv@users.noreply.github.com>
>+Date: Wed, 14 Jul 2021 20:34:39 +0200
>+Subject: [PATCH] Remove last remnants of uigtk
>+
>+---
>+ src/.depend | 4 ----
>+ src/Makefile.OCaml | 9 ---------
>+ src/dune | 2 +-
>+ src/linkgtk.ml | 19 -------------------
>+ 4 files changed, 1 insertion(+), 33 deletions(-)
>+ delete mode 100644 src/linkgtk.ml
>+
>+diff --git a/src/.depend b/src/.depend
>+index f466ad02a..b9b9fa36c 100644
>+--- a/src/.depend
>++++ b/src/.depend
>+@@ -523,10 +523,6 @@ globals.cmi : \
>+ path.cmi \
>+ lwt/lwt.cmi \
>+ common.cmi
>+-linkgtk.cmo : \
>+- main.cmo
>+-linkgtk.cmx : \
>+- main.cmx
>+ linkgtk2.cmo : \
>+ uigtk2.cmi \
>+ main.cmo
>+diff --git a/src/Makefile.OCaml b/src/Makefile.OCaml
>+index 2a4afba53..61e82b18b 100644
>+--- a/src/Makefile.OCaml
>++++ b/src/Makefile.OCaml
>+@@ -66,13 +66,11 @@ OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | tr '\\' '/' | tr -
>+ # User interface style:
>+ # Legal values are
>+ # UISTYLE=text
>+-# UISTYLE=gtk
>+ # UISTYLE=gtk2
>+ # UISTYLE=mac
>+ #
>+ # This should be set to an appropriate value automatically, depending
>+ # on whether the lablgtk library is available
>+-LABLGTKLIB=$(OCAMLLIBDIR)/lablgtk
>+ LABLGTK2LIB=$(OCAMLLIBDIR)/lablgtk3
>+ ##BCP [3/2007]: Removed temporarily, since the OSX UI is not working well
>+ ## at the moment and we don't want to confuse people by building it by default
>+@@ -282,13 +280,6 @@ ifeq ($(OSARCH), win32)
>+ endif
>+ endif
>+ 
>+-# Gtk GUI
>+-ifeq ($(UISTYLE), gtk)
>+- CAMLFLAGS+=-I +lablgtk
>+- OCAMLOBJS+=pixmaps.cmo uigtk.cmo linkgtk.cmo
>+- OCAMLLIBS+=lablgtk.cma
>+-endif
>+-
>+ # Gtk2 GUI
>+ OCAMLFIND := $(shell command -v ocamlfind 2> /dev/null)
>+ 
>+diff --git a/src/dune b/src/dune
>+index cdc4404fe..a732a498d 100644
>+--- a/src/dune
>++++ b/src/dune
>+@@ -1,7 +1,7 @@
>+ (library
>+ (name unison_lib)
>+ (wrapped false)
>+- (modules :standard \ linktext linkgtk linkgtk2 uigtk2 uimacbridge uimacbridgenew test)
>++ (modules :standard \ linktext linkgtk2 uigtk2 uimacbridge uimacbridgenew test)
>+ (modules_without_implementation ui)
>+ (flags :standard
>+ -w -3-6-9-10-26-27-32-34-35-38-39-50-52
>+diff --git a/src/linkgtk.ml b/src/linkgtk.ml
>+deleted file mode 100644
>+index a77759362..000000000
>+--- a/src/linkgtk.ml
>++++ /dev/null
>+@@ -1,19 +0,0 @@
>+-(* Unison file synchronizer: src/linkgtk.ml *)
>+-(* Copyright 1999-2020, Benjamin C. Pierce
>+-
>+- This program 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 3 of the License, or
>+- (at your option) any later version.
>+-
>+- This program is distributed in the hope that it will be useful,
>+- but WITHOUT ANY WARRANTY; without even the implied warranty of
>+- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
>+- GNU General Public License for more details.
>+-
>+- You should have received a copy of the GNU General Public License
>+- along with this program. If not, see <http://www.gnu.org/licenses/>.
>+-*)
>+-
>+-
>+-module TopLevel = Main.Body(Uigtk.Body)
>diff --git a/net-misc/unison/files/e05957692b1e21517708e4252f3b0e22cb1ac206.patch b/net-misc/unison/files/e05957692b1e21517708e4252f3b0e22cb1ac206.patch
>new file mode 100644
>index 00000000000..8e61a868b4b
>--- /dev/null
>+++ b/net-misc/unison/files/e05957692b1e21517708e4252f3b0e22cb1ac206.patch
>@@ -0,0 +1,8722 @@
>+From e05957692b1e21517708e4252f3b0e22cb1ac206 Mon Sep 17 00:00:00 2001
>+From: =?UTF-8?q?T=C3=B5ivo=20Leedj=C3=A4rv?=
>+ <69477666+tleedjarv@users.noreply.github.com>
>+Date: Wed, 14 Jul 2021 20:38:12 +0200
>+Subject: [PATCH] uigtk2 -> uigtk3
>+
>+---
>+ .github/workflows/CICD.yml | 4 ++--
>+ src/.depend | 18 +++++++++---------
>+ src/Makefile.OCaml | 20 ++++++++++----------
>+ src/dune | 8 ++++----
>+ src/{linkgtk2.ml => linkgtk3.ml} | 4 ++--
>+ src/{uigtk2.ml => uigtk3.ml} | 2 +-
>+ src/{uigtk2.mli => uigtk3.mli} | 2 +-
>+ 7 files changed, 29 insertions(+), 29 deletions(-)
>+ rename src/{linkgtk2.ml => linkgtk3.ml} (88%)
>+ rename src/{uigtk2.ml => uigtk3.ml} (99%)
>+ rename src/{uigtk2.mli => uigtk3.mli} (67%)
>+
>+Index: unison-2.51.5/.github/workflows/CICD.yml
>+===================================================================
>+--- unison-2.51.5.orig/.github/workflows/CICD.yml
>++++ unison-2.51.5/.github/workflows/CICD.yml
>+@@ -176,11 +176,11 @@ jobs:
>+ - if: steps.vars.outputs.STATIC != 'true' ## unable to build static gtk for linux or windows/Cygwin MinGW platforms
>+ shell: bash
>+ run: |
>+- opam exec -- make src OSTYPE=$OSTYPE UISTYLE=gtk2 STATIC=${{ steps.vars.outputs.STATIC }}
>++ opam exec -- make src OSTYPE=$OSTYPE UISTYLE=gtk3 STATIC=${{ steps.vars.outputs.STATIC }}
>+ # stage
>+ # * copy only main/first project binary
>+ project_exe_stem=${PROJECT_EXES%% *}
>+- cp "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" "${{ steps.vars.outputs.PKG_DIR }}/bin/${project_exe_stem}-gtk2${{ steps.vars.outputs.EXE_suffix }}"
>++ cp "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" "${{ steps.vars.outputs.PKG_DIR }}/bin/${project_exe_stem}-gtk3${{ steps.vars.outputs.EXE_suffix }}"
>+ 
>+ - uses: actions/upload-artifact@v2
>+ with:
>+Index: unison-2.51.5/src/.depend
>+===================================================================
>+--- unison-2.51.5.orig/src/.depend
>++++ unison-2.51.5/src/.depend
>+@@ -514,11 +514,11 @@ globals.cmi : \
>+ path.cmi \
>+ lwt/lwt.cmi \
>+ common.cmi
>+-linkgtk2.cmo : \
>+- uigtk2.cmi \
>++linkgtk3.cmo : \
>++ uigtk3.cmi \
>+ main.cmo
>+-linkgtk2.cmx : \
>+- uigtk2.cmx \
>++linkgtk3.cmx : \
>++ uigtk3.cmx \
>+ main.cmx
>+ linktext.cmo : \
>+ uitext.cmi \
>+@@ -1209,7 +1209,7 @@ uicommon.cmi : \
>+ path.cmi \
>+ lwt/lwt.cmi \
>+ common.cmi
>+-uigtk2.cmo : \
>++uigtk3.cmo : \
>+ uutil.cmi \
>+ ubase/util.cmi \
>+ update.cmi \
>+@@ -1235,8 +1235,8 @@ uigtk2.cmo : \
>+ common.cmi \
>+ clroot.cmi \
>+ case.cmi \
>+- uigtk2.cmi
>+-uigtk2.cmx : \
>++ uigtk3.cmi
>++uigtk3.cmx : \
>+ uutil.cmx \
>+ ubase/util.cmx \
>+ update.cmx \
>+@@ -1262,8 +1262,8 @@ uigtk2.cmx : \
>+ common.cmx \
>+ clroot.cmx \
>+ case.cmx \
>+- uigtk2.cmi
>+-uigtk2.cmi : \
>++ uigtk3.cmi
>++uigtk3.cmi : \
>+ uicommon.cmi
>+ uimacbridge.cmo : \
>+ xferhint.cmi \
>+Index: unison-2.51.5/src/Makefile.OCaml
>+===================================================================
>+--- unison-2.51.5.orig/src/Makefile.OCaml
>++++ unison-2.51.5/src/Makefile.OCaml
>+@@ -69,23 +69,23 @@ OCAMLLIBDIR=$(shell ocamlc -v | tail -1
>+ # User interface style:
>+ # Legal values are
>+ # UISTYLE=text
>+-# UISTYLE=gtk2
>++# UISTYLE=gtk3
>+ # UISTYLE=mac
>+ #
>+ # This should be set to an appropriate value automatically, depending
>+ # on whether the lablgtk library is available
>+-LABLGTK2LIB=$(OCAMLLIBDIR)/lablgtk3
>++LABLGTK3LIB=$(OCAMLLIBDIR)/lablgtk3
>+ ##BCP [3/2007]: Removed temporarily, since the OSX UI is not working well
>+ ## at the moment and we don't want to confuse people by building it by default
>+ ifeq ($(OSARCH),osx)
>+ UISTYLE=mac
>+ else
>+- ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB))
>+- UISTYLE=gtk2
>++ ifeq ($(wildcard $(LABLGTK3LIB)),$(LABLGTK3LIB))
>++ UISTYLE=gtk3
>+ else
>+- LABLGTK2LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk3)
>+- ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB))
>+- UISTYLE=gtk2
>++ LABLGTK3LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk3)
>++ ifeq ($(wildcard $(LABLGTK3LIB)),$(LABLGTK3LIB))
>++ UISTYLE=gtk3
>+ else
>+ UISTYLE=text
>+ endif
>+@@ -271,16 +271,16 @@ ifeq ($(OSARCH), win32)
>+ endif
>+ endif
>+ 
>+-# Gtk2 GUI
>++# Gtk3 GUI
>+ OCAMLFIND := $(shell command -v ocamlfind 2> /dev/null)
>+ 
>+-ifeq ($(UISTYLE), gtk2)
>++ifeq ($(UISTYLE), gtk3)
>+ ifndef OCAMLFIND
>+ CAMLFLAGS+=-I +lablgtk3
>+ else
>+ CAMLFLAGS+=$(shell $(OCAMLFIND) query -i-format lablgtk3 )
>+ endif
>+- OCAMLOBJS+=pixmaps.cmo uigtk2.cmo linkgtk2.cmo
>++ OCAMLOBJS+=pixmaps.cmo uigtk3.cmo linkgtk3.cmo
>+ OCAMLLIBS+=lablgtk3.cma
>+ endif
>+ 
>+Index: unison-2.51.5/src/dune
>+===================================================================
>+--- unison-2.51.5.orig/src/dune
>++++ unison-2.51.5/src/dune
>+@@ -1,7 +1,7 @@
>+ (library
>+ (name unison_lib)
>+ (wrapped false)
>+- (modules :standard \ linktext linkgtk2 uigtk2 uimacbridge uimacbridgenew test)
>++ (modules :standard \ linktext linkgtk3 uigtk3 uimacbridge uimacbridgenew test)
>+ (modules_without_implementation ui)
>+ (flags :standard
>+ -w -3-6-9-10-26-27-32-34-35-38-39-50-52
>+@@ -22,8 +22,8 @@
>+ (libraries unison_lib))
>+ 
>+ (executable
>+- (name linkgtk2)
>+- (public_name unison-gtk2)
>++ (name linkgtk3)
>++ (public_name unison-gtk3)
>+ (flags :standard -w -3-6-9-27-32-52)
>+- (modules linkgtk2 uigtk2)
>++ (modules linkgtk3 uigtk3)
>+ (libraries threads unison_lib lablgtk3))
>+Index: unison-2.51.5/src/linkgtk2.ml
>+===================================================================
>+--- unison-2.51.5.orig/src/linkgtk2.ml
>++++ /dev/null
>+@@ -1,19 +0,0 @@
>+-(* Unison file synchronizer: src/linkgtk2.ml *)
>+-(* Copyright 1999-2020, Benjamin C. Pierce
>+-
>+- This program 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 3 of the License, or
>+- (at your option) any later version.
>+-
>+- This program is distributed in the hope that it will be useful,
>+- but WITHOUT ANY WARRANTY; without even the implied warranty of
>+- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
>+- GNU General Public License for more details.
>+-
>+- You should have received a copy of the GNU General Public License
>+- along with this program. If not, see <http://www.gnu.org/licenses/>.
>+-*)
>+-
>+-
>+-module TopLevel = Main.Body(Uigtk2.Body)
>+Index: unison-2.51.5/src/linkgtk3.ml
>+===================================================================
>+--- /dev/null
>++++ unison-2.51.5/src/linkgtk3.ml
>+@@ -0,0 +1,19 @@
>++(* Unison file synchronizer: src/linkgtk3.ml *)
>++(* Copyright 1999-2020, Benjamin C. Pierce
>++
>++ This program 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 3 of the License, or
>++ (at your option) any later version.
>++
>++ This program is distributed in the hope that it will be useful,
>++ but WITHOUT ANY WARRANTY; without even the implied warranty of
>++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
>++ GNU General Public License for more details.
>++
>++ You should have received a copy of the GNU General Public License
>++ along with this program. If not, see <http://www.gnu.org/licenses/>.
>++*)
>++
>++
>++module TopLevel = Main.Body(Uigtk3.Body)
>+Index: unison-2.51.5/src/uigtk2.ml
>+===================================================================
>+--- unison-2.51.5.orig/src/uigtk2.ml
>++++ /dev/null
>+@@ -1,4239 +0,0 @@
>+-(* Unison file synchronizer: src/uigtk2.ml *)
>+-(* Copyright 1999-2020, Benjamin C. Pierce
>+-
>+- This program 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 3 of the License, or
>+- (at your option) any later version.
>+-
>+- This program is distributed in the hope that it will be useful,
>+- but WITHOUT ANY WARRANTY; without even the implied warranty of
>+- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
>+- GNU General Public License for more details.
>+-
>+- You should have received a copy of the GNU General Public License
>+- along with this program. If not, see <http://www.gnu.org/licenses/>.
>+-*)
>+-
>+-
>+-open Common
>+-open Lwt
>+-
>+-module Private = struct
>+-
>+-let debug = Trace.debug "ui"
>+-
>+-let myNameCapitalized = String.capitalize_ascii Uutil.myName
>+-
>+-(**********************************************************************
>+- LOW-LEVEL STUFF
>+- **********************************************************************)
>+-
>+-(**********************************************************************
>+- Some message strings (build them here because they look ugly in the
>+- middle of other code.
>+- **********************************************************************)
>+-
>+-let tryAgainMessage =
>+- Printf.sprintf
>+-"You can use %s to synchronize a local directory with another local directory,
>+-or with a remote directory.
>+-
>+-Please enter the first (local) directory that you want to synchronize."
>+-myNameCapitalized
>+-
>+-(* ---- *)
>+-
>+-let helpmessage = Printf.sprintf
>+-"%s can synchronize a local directory with another local directory, or with
>+-a directory on a remote machine.
>+-
>+-To synchronize with a local directory, just enter the file name.
>+-
>+-To synchronize with a remote directory, you must first choose a protocol
>+-that %s will use to connect to the remote machine. Each protocol has
>+-different requirements:
>+-
>+-1) To synchronize using SSH, there must be an SSH client installed on
>+-this machine and an SSH server installed on the remote machine. You
>+-must enter the host to connect to, a user name (if different from
>+-your user name on this machine), and the directory on the remote machine
>+-(relative to your home directory on that machine).
>+-
>+-2) To synchronize using RSH, there must be an RSH client installed on
>+-this machine and an RSH server installed on the remote machine. You
>+-must enter the host to connect to, a user name (if different from
>+-your user name on this machine), and the directory on the remote machine
>+-(relative to your home directory on that machine).
>+-
>+-3) To synchronize using %s's socket protocol, there must be a %s
>+-server running on the remote machine, listening to the port that you
>+-specify here. (Use \"%s -socket xxx\" on the remote machine to
>+-start the %s server.) You must enter the host, port, and the directory
>+-on the remote machine (relative to the working directory of the
>+-%s server running on that machine)."
>+-myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized
>+-
>+-(**********************************************************************
>+- Font preferences
>+- **********************************************************************)
>+-
>+-let fontMonospace = lazy (Pango.Font.from_string "monospace")
>+-let fontBold = lazy (Pango.Font.from_string "bold")
>+-let fontItalic = lazy (Pango.Font.from_string "italic")
>+-
>+-(**********************************************************************
>+- Unison icon
>+- **********************************************************************)
>+-
>+-(* This does not work with the current version of Lablgtk, due to a bug
>+-let icon =
>+- GdkPixbuf.from_data ~width:48 ~height:48 ~has_alpha:true
>+- (Gpointer.region_of_bytes Pixmaps.icon_data)
>+-*)
>+-let icon =
>+- let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in
>+- let pxs = GdkPixbuf.get_pixels p in
>+- (* This little hack is here to support compiling with lablgtk versions both
>+- < 2.18.6 and >= 2.18.6 *)
>+- String.iteri (fun i c -> Gpointer.set_byte pxs ~pos:i (Char.code c)) Pixmaps.icon_data;
>+- p
>+-
>+-let leftPtrWatch =
>+- lazy (Gdk.Cursor.create `WATCH)
>+-
>+-let make_busy w =
>+- if Util.osType <> `Win32 then
>+- Gdk.Window.set_cursor w#misc#window (Lazy.force leftPtrWatch)
>+-let make_interactive w =
>+- if Util.osType <> `Win32 then
>+- (* HACK: setting the cursor to NULL restore the default cursor *)
>+- Gdk.Window.set_cursor w#misc#window (Obj.magic Gpointer.boxed_null)
>+-
>+-(*********************************************************************
>+- UI state variables
>+- *********************************************************************)
>+-
>+-type stateItem = { mutable ri : reconItem;
>+- mutable bytesTransferred : Uutil.Filesize.t;
>+- mutable bytesToTransfer : Uutil.Filesize.t;
>+- mutable whatHappened : (Util.confirmation * string option) option}
>+-let theState = ref [||]
>+-let unsynchronizedPaths = ref None
>+-
>+-(* ---- *)
>+-
>+-let theToplevelWindow = ref None
>+-let setToplevelWindow w = theToplevelWindow := Some w
>+-let toplevelWindow () =
>+- match !theToplevelWindow with
>+- Some w -> w
>+- | None -> raise (Util.Fatal "Main window not initialized; check your DISPLAY setup")
>+-
>+-(*********************************************************************
>+- Lock management
>+- *********************************************************************)
>+-
>+-let busy = ref false
>+-
>+-let getLock f =
>+- if !busy then
>+- Trace.status "Synchronizer is busy, please wait.."
>+- else begin
>+- busy := true; f (); busy := false
>+- end
>+-
>+-(**********************************************************************
>+- Miscellaneous
>+- **********************************************************************)
>+-
>+-let sync_action = ref None
>+-
>+-let last = ref (0.)
>+-
>+-let gtk_sync forced =
>+- let t = Unix.gettimeofday () in
>+- if !last = 0. || forced || t -. !last > 0.05 then begin
>+- last := t;
>+- begin match !sync_action with
>+- Some f -> f ()
>+- | None -> ()
>+- end;
>+- while Glib.Main.iteration false do () done
>+- end
>+-
>+-(**********************************************************************
>+- CHARACTER SET TRANSCODING
>+-***********************************************************************)
>+-
>+-(* Transcodage from Microsoft Windows Codepage 1252 to Unicode *)
>+-
>+-(* Unison currently uses the "ASCII" Windows filesystem API. With
>+- this API, filenames are encoded using a proprietary character
>+- encoding. This encoding depends on the Windows setup, but in
>+- Western Europe, the Windows Codepage 1252 is usually used.
>+- GTK, on the other hand, uses the UTF-8 encoding. This code perform
>+- the translation from Codepage 1252 to UTF-8. A call to [transcode]
>+- should be wrapped around every string below that might contain
>+- non-ASCII characters. *)
>+-
>+-let code =
>+- [| 0x0020; 0x0001; 0x0002; 0x0003; 0x0004; 0x0005; 0x0006; 0x0007;
>+- 0x0008; 0x0009; 0x000A; 0x000B; 0x000C; 0x000D; 0x000E; 0x000F;
>+- 0x0010; 0x0011; 0x0012; 0x0013; 0x0014; 0x0015; 0x0016; 0x0017;
>+- 0x0018; 0x0019; 0x001A; 0x001B; 0x001C; 0x001D; 0x001E; 0x001F;
>+- 0x0020; 0x0021; 0x0022; 0x0023; 0x0024; 0x0025; 0x0026; 0x0027;
>+- 0x0028; 0x0029; 0x002A; 0x002B; 0x002C; 0x002D; 0x002E; 0x002F;
>+- 0x0030; 0x0031; 0x0032; 0x0033; 0x0034; 0x0035; 0x0036; 0x0037;
>+- 0x0038; 0x0039; 0x003A; 0x003B; 0x003C; 0x003D; 0x003E; 0x003F;
>+- 0x0040; 0x0041; 0x0042; 0x0043; 0x0044; 0x0045; 0x0046; 0x0047;
>+- 0x0048; 0x0049; 0x004A; 0x004B; 0x004C; 0x004D; 0x004E; 0x004F;
>+- 0x0050; 0x0051; 0x0052; 0x0053; 0x0054; 0x0055; 0x0056; 0x0057;
>+- 0x0058; 0x0059; 0x005A; 0x005B; 0x005C; 0x005D; 0x005E; 0x005F;
>+- 0x0060; 0x0061; 0x0062; 0x0063; 0x0064; 0x0065; 0x0066; 0x0067;
>+- 0x0068; 0x0069; 0x006A; 0x006B; 0x006C; 0x006D; 0x006E; 0x006F;
>+- 0x0070; 0x0071; 0x0072; 0x0073; 0x0074; 0x0075; 0x0076; 0x0077;
>+- 0x0078; 0x0079; 0x007A; 0x007B; 0x007C; 0x007D; 0x007E; 0x007F;
>+- 0x20AC; 0x1234; 0x201A; 0x0192; 0x201E; 0x2026; 0x2020; 0x2021;
>+- 0x02C6; 0x2030; 0x0160; 0x2039; 0x0152; 0x1234; 0x017D; 0x1234;
>+- 0x1234; 0x2018; 0x2019; 0x201C; 0x201D; 0x2022; 0x2013; 0x2014;
>+- 0x02DC; 0x2122; 0x0161; 0x203A; 0x0153; 0x1234; 0x017E; 0x0178;
>+- 0x00A0; 0x00A1; 0x00A2; 0x00A3; 0x00A4; 0x00A5; 0x00A6; 0x00A7;
>+- 0x00A8; 0x00A9; 0x00AA; 0x00AB; 0x00AC; 0x00AD; 0x00AE; 0x00AF;
>+- 0x00B0; 0x00B1; 0x00B2; 0x00B3; 0x00B4; 0x00B5; 0x00B6; 0x00B7;
>+- 0x00B8; 0x00B9; 0x00BA; 0x00BB; 0x00BC; 0x00BD; 0x00BE; 0x00BF;
>+- 0x00C0; 0x00C1; 0x00C2; 0x00C3; 0x00C4; 0x00C5; 0x00C6; 0x00C7;
>+- 0x00C8; 0x00C9; 0x00CA; 0x00CB; 0x00CC; 0x00CD; 0x00CE; 0x00CF;
>+- 0x00D0; 0x00D1; 0x00D2; 0x00D3; 0x00D4; 0x00D5; 0x00D6; 0x00D7;
>+- 0x00D8; 0x00D9; 0x00DA; 0x00DB; 0x00DC; 0x00DD; 0x00DE; 0x00DF;
>+- 0x00E0; 0x00E1; 0x00E2; 0x00E3; 0x00E4; 0x00E5; 0x00E6; 0x00E7;
>+- 0x00E8; 0x00E9; 0x00EA; 0x00EB; 0x00EC; 0x00ED; 0x00EE; 0x00EF;
>+- 0x00F0; 0x00F1; 0x00F2; 0x00F3; 0x00F4; 0x00F5; 0x00F6; 0x00F7;
>+- 0x00F8; 0x00F9; 0x00FA; 0x00FB; 0x00FC; 0x00FD; 0x00FE; 0x00FF |]
>+-
>+-let rec transcodeRec buf s i l =
>+- if i < l then begin
>+- let c = code.(Char.code s.[i]) in
>+- if c < 0x80 then
>+- Buffer.add_char buf (Char.chr c)
>+- else if c < 0x800 then begin
>+- Buffer.add_char buf (Char.chr (c lsr 6 + 0xC0));
>+- Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))
>+- end else if c < 0x10000 then begin
>+- Buffer.add_char buf (Char.chr (c lsr 12 + 0xE0));
>+- Buffer.add_char buf (Char.chr ((c lsr 6) land 0x3f + 0x80));
>+- Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))
>+- end;
>+- transcodeRec buf s (i + 1) l
>+- end
>+-
>+-let transcodeDoc s =
>+- let buf = Buffer.create 1024 in
>+- transcodeRec buf s 0 (String.length s);
>+- Buffer.contents buf
>+-
>+-(****)
>+-
>+-let escapeMarkup s = Glib.Markup.escape_text s
>+-
>+-let transcodeFilename s =
>+- if Prefs.read Case.unicodeEncoding then
>+- Unicode.protect s
>+- else if Util.osType = `Win32 then transcodeDoc s else
>+- try
>+- Glib.Convert.filename_to_utf8 s
>+- with Glib.Convert.Error _ ->
>+- Unicode.protect s
>+-
>+-let transcode s =
>+- if Prefs.read Case.unicodeEncoding then
>+- Unicode.protect s
>+- else
>+- try
>+- Glib.Convert.locale_to_utf8 s
>+- with Glib.Convert.Error _ ->
>+- Unicode.protect s
>+-
>+-(**********************************************************************
>+- USEFUL LOW-LEVEL WIDGETS
>+- **********************************************************************)
>+-
>+-class scrolled_text ?editable ?shadow_type ?word_wrap
>+- ~width ~height ?packing ?show
>+- () =
>+- let sw =
>+- GBin.scrolled_window ?packing ~show:false
>+- ?shadow_type ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
>+- in
>+- let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in
>+- object
>+- inherit GObj.widget_full sw#as_widget
>+- method text = text
>+- method insert s = text#buffer#set_text s;
>+- method show () = sw#misc#show ()
>+- initializer
>+- text#misc#set_size_chars ~height ~width ();
>+- if show <> Some false then sw#misc#show ()
>+- end
>+-
>+-(* ------ *)
>+-
>+-(* Display a message in a window and wait for the user
>+- to hit the button. *)
>+-let okBox ~parent ~title ~typ ~message =
>+- let t =
>+- GWindow.message_dialog
>+- ~parent ~title ~message_type:typ ~message ~modal:true
>+- ~buttons:GWindow.Buttons.ok () in
>+- ignore (t#run ()); t#destroy ()
>+-
>+-(* ------ *)
>+-
>+-let primaryText msg =
>+- Printf.sprintf "%s"
>+- (escapeMarkup msg)
>+-
>+-(* twoBox: Display a message in a window and wait for the user
>+- to hit one of two buttons. Return true if the first button is
>+- chosen, false if the second button is chosen. *)
>+-let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message =
>+- let t =
>+- GWindow.dialog ~parent ~border_width:6 ~modal:true
>+- ~resizable:false () in
>+- t#vbox#set_spacing 12;
>+- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+- ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG
>+- ~yalign:0. ~packing:h1#pack ());
>+- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>+- ignore (GMisc.label
>+- ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)
>+- ~selectable:true ~yalign:0. ~packing:v1#add ());
>+- t#add_button_stock bstock `NO;
>+- t#add_button_stock astock `YES;
>+- t#set_default_response `NO;
>+- t#show();
>+- let res = t#run () in
>+- t#destroy ();
>+- res = `YES
>+-
>+-(* ------ *)
>+-
>+-(* Avoid recursive invocations of the function below (a window receives
>+- delete events even when it is not sensitive) *)
>+-let inExit = ref false
>+-
>+-let doExit () = Lwt_unix.run (Update.unlockArchives ()); exit 0
>+-
>+-let safeExit () =
>+- if not !inExit then begin
>+- inExit := true;
>+- if not !busy then exit 0 else
>+- if twoBox ~parent:(toplevelWindow ()) ~title:"Premature exit"
>+- ~astock:`YES ~bstock:`NO
>+- "Unison is working, exit anyway ?"
>+- then exit 0;
>+- inExit := false
>+- end
>+-
>+-(* ------ *)
>+-
>+-(* warnBox: Display a warning message in a window and wait (unless
>+- we're in batch mode) for the user to hit "OK" or "Exit". *)
>+-let warnBox ~parent title message =
>+- let message = transcode message in
>+- if Prefs.read Globals.batch then begin
>+- (* In batch mode, just pop up a window and go ahead *)
>+- let t =
>+- GWindow.dialog ~parent
>+- ~border_width:6 ~modal:true ~resizable:false () in
>+- t#vbox#set_spacing 12;
>+- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+- ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
>+- ~yalign:0. ~packing:h1#pack ());
>+- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>+- ignore (GMisc.label ~markup:(primaryText title ^ "\n\n" ^
>+- escapeMarkup message)
>+- ~selectable:true ~yalign:0. ~packing:v1#add ());
>+- t#add_button_stock `CLOSE `CLOSE;
>+- t#set_default_response `CLOSE;
>+- ignore (t#connect#response ~callback:(fun _ -> t#destroy ()));
>+- t#show ()
>+- end else begin
>+- inExit := true;
>+- let ok =
>+- twoBox ~parent:(toplevelWindow ()) ~title ~astock:`OK ~bstock:`QUIT
>+- message in
>+- if not(ok) then doExit ();
>+- inExit := false
>+- end
>+-
>+-(****)
>+-
>+-let accel_paths = Hashtbl.create 17
>+-let underscore_re = Str.regexp_string "_"
>+-class ['a] gMenuFactory
>+- ?(accel_group=GtkData.AccelGroup.create ())
>+- ?(accel_path="<DEFAULT ROOT>/")
>+- ?(accel_modi=[`CONTROL])
>+- ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) =
>+- object (self)
>+- val menu_shell : #GMenu.menu_shell = menu_shell
>+- val group = accel_group
>+- val m = accel_modi
>+- val flags = (accel_flags:Gtk.Tags.accel_flag list)
>+- val accel_path = accel_path
>+- method menu = menu_shell
>+- method accel_group = group
>+- method accel_path = accel_path
>+- method private bind
>+- ?(modi=m) ?key ?callback label ?(name=label) (item : GMenu.menu_item) =
>+- menu_shell#append item;
>+- let accel_path = accel_path ^ name in
>+- let accel_path = Str.global_replace underscore_re "" accel_path in
>+- (* Default accel path value *)
>+- if not (Hashtbl.mem accel_paths accel_path) then begin
>+- Hashtbl.add accel_paths accel_path ();
>+- GtkData.AccelMap.add_entry accel_path ?key ~modi
>+- end;
>+- (* Register this accel path *)
>+- GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group;
>+- Gaux.may callback ~f:(fun callback -> item#connect#activate ~callback)
>+- method add_item ?key ?modi ?callback ?submenu label =
>+- let item = GMenu.menu_item ~use_mnemonic:true ~label () in
>+- self#bind ?modi ?key ?callback label item;
>+- Gaux.may (submenu : GMenu.menu option) ~f:item#set_submenu;
>+- item
>+- method add_image_item ?(image : GObj.widget option)
>+- ?modi ?key ?callback ?stock ?name label =
>+- (* GTK 3 does not provide image menu items (there is a way to
>+- manually create a workaround but that does not work with
>+- lablgtk. Let's create a regular menu item instead. *)
>+- let item =
>+- GMenu.menu_item ~use_mnemonic:true ~label () in
>+- match stock with
>+- | None ->
>+- self#bind ?modi ?key ?callback label ?name item;
>+- item
>+- | Some s ->
>+- try
>+- let st = GtkStock.Item.lookup s in
>+- self#bind
>+- ?modi ?key:(if st.GtkStock.keyval=0 then key else None)
>+- ?callback label ?name item;
>+- item
>+- with Not_found -> item
>+-
>+- method add_check_item ?active ?modi ?key ?callback label =
>+- let item = GMenu.check_menu_item ~label ~use_mnemonic:true ?active () in
>+- self#bind label ?modi ?key
>+- ?callback:(Gaux.may_map callback ~f:(fun f () -> f item#active))
>+- (item : GMenu.check_menu_item :> GMenu.menu_item);
>+- item
>+- method add_separator () = GMenu.separator_item ~packing:menu_shell#append ()
>+- method add_submenu label =
>+- let item = GMenu.menu_item ~use_mnemonic:true ~label () in
>+- self#bind label item;
>+- (GMenu.menu ~packing:item#set_submenu (), item)
>+- method replace_submenu (item : GMenu.menu_item) =
>+- GMenu.menu ~packing:item#set_submenu ()
>+-end
>+-
>+-(**********************************************************************
>+- HIGHER-LEVEL WIDGETS
>+-***********************************************************************)
>+-
>+-(*class stats width height =
>+- let pixmap = GDraw.pixmap ~width ~height () in
>+- let area =
>+- pixmap#set_foreground `WHITE;
>+- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
>+- GMisc.pixmap pixmap ~width ~height ~xpad:4 ~ypad:8 ()
>+- in
>+- object (self)
>+- inherit GObj.widget_full area#as_widget
>+- val mutable maxim = ref 0.
>+- val mutable scale = ref 1.
>+- val mutable min_scale = 1.
>+- val values = Array.make width 0.
>+- val mutable active = false
>+-
>+- method redraw () =
>+- scale := min_scale;
>+- while !maxim > !scale do
>+- scale := !scale *. 1.5
>+- done;
>+- pixmap#set_foreground `WHITE;
>+- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
>+- pixmap#set_foreground `BLACK;
>+- for i = 0 to width - 1 do
>+- self#rect i values.(max 0 (i - 1)) values.(i)
>+- done
>+-
>+- method activate a = active <- a; if a then self#redraw ()
>+-
>+- method scale h = truncate ((float height) *. h /. !scale)
>+-
>+- method private rect i v' v =
>+- let h = self#scale v in
>+- let h' = self#scale v' in
>+- let h1 = min h' h in
>+- let h2 = max h' h in
>+- pixmap#set_foreground `BLACK;
>+- pixmap#rectangle
>+- ~filled:true ~x:i ~y:(height - h1) ~width:1 ~height:h1 ();
>+- for h = h1 + 1 to h2 do
>+- let v = truncate (65535. *. (float (h - h1) /. float (h2 - h1))) in
>+- let v = (v / 4096) * 4096 in (* Only use 16 gray levels *)
>+- pixmap#set_foreground (`RGB (v, v, v));
>+- pixmap#rectangle
>+- ~filled:true ~x:i ~y:(height - h) ~width:1 ~height:1 ();
>+- done
>+-
>+- method push v =
>+- let need_max = values.(0) = !maxim in
>+- for i = 0 to width - 2 do
>+- values.(i) <- values.(i + 1)
>+- done;
>+- values.(width - 1) <- v;
>+- if need_max then begin
>+- maxim := 0.;
>+- for i = 0 to width - 1 do maxim := max !maxim values.(i) done
>+- end else
>+- maxim := max !maxim v;
>+- if active then begin
>+- let need_resize =
>+- !maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in
>+- if need_resize then
>+- self#redraw ()
>+- else begin
>+- pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap);
>+- pixmap#set_foreground `WHITE;
>+- pixmap#rectangle
>+- ~filled:true ~x:(width - 1) ~y:0 ~width:1 ~height ();
>+- self#rect (width - 1) values.(width - 2) values.(width - 1)
>+- end;
>+- area#misc#draw None
>+- end
>+- end
>+-*)
>+-let clientWritten = ref 0.
>+-let serverWritten = ref 0.
>+-let emitRate2 = ref 0.
>+-let receiveRate2 = ref 0.
>+-
>+-let rate2str v =
>+- if v > 9.9e3 then begin
>+- if v > 9.9e6 then
>+- Format.sprintf "%1.0f MiB/s" (v /. 1e6)
>+- else if v > 999e3 then
>+- Format.sprintf "%1.1f MiB/s" (v /. 1e6)
>+- else
>+- Format.sprintf "%1.0f KiB/s" (v /. 1e3)
>+- end else begin
>+- if v > 990. then
>+- Format.sprintf "%1.1f KiB/s" (v /. 1e3)
>+- else if v > 99. then
>+- Format.sprintf "%1.2f KiB/s" (v /. 1e3)
>+- else
>+- " "
>+- end
>+-
>+-let mib = 1024. *. 1024.
>+-let kib2str v =
>+- if v > 100_000_000. then
>+- Format.sprintf "%.0f MiB" (v /. mib)
>+- else if v > 1_000_000. then
>+- Format.sprintf "%.1f MiB" (v /. mib)
>+- else if v > 1024. then
>+- Format.sprintf "%.1f KiB" (v /. 1024.)
>+- else
>+- Format.sprintf "%.0f B" v
>+-
>+-let statistics () =
>+- let title = "Statistics" in
>+- let t = GWindow.dialog ~title () in
>+- let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
>+- t_dismiss#grab_default ();
>+- let dismiss () = t#misc#hide () in
>+- ignore (t_dismiss#connect#clicked ~callback:dismiss);
>+- ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));
>+-
>+-(* let emission = new stats 320 50 in
>+- t#vbox#pack ~expand:false ~padding:4 (emission :> GObj.widget);
>+- let reception = new stats 320 50 in
>+- t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);*)
>+-
>+- let cols = new GTree.column_list in
>+- let c_1 = cols#add Gobject.Data.string in
>+- let c_client = cols#add Gobject.Data.string in
>+- let c_server = cols#add Gobject.Data.string in
>+- let c_total = cols#add Gobject.Data.string in
>+- let lst = GTree.list_store cols in
>+- let l = GTree.view ~model:lst ~enable_search:false ~packing:(t#vbox#add) () in
>+- l#selection#set_mode `NONE;
>+- ignore (l#append_column (GTree.view_column ~title:""
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_1]) ()));
>+- ignore (l#append_column (GTree.view_column ~title:"Client"
>+- ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_client]) ()));
>+- ignore (l#append_column (GTree.view_column ~title:"Server"
>+- ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_server]) ()));
>+- ignore (l#append_column (GTree.view_column ~title:"Total"
>+- ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_total]) ()));
>+- let rate_row = lst#append () in
>+- ignore (lst#set rate_row c_1 "Reception rate");
>+- let receive_row = lst#append () in
>+- ignore (lst#set receive_row c_1 "Data received");
>+- let data_row = lst#append () in
>+- ignore (lst#set data_row c_1 "File data written");
>+-(*
>+- ignore (t#event#connect#map ~callback:(fun _ ->
>+- emission#activate true;
>+- reception#activate true;
>+- false));
>+- ignore (t#event#connect#unmap ~callback:(fun _ ->
>+- emission#activate false;
>+- reception#activate false;
>+- false));*)
>+-
>+- let delay = 0.5 in
>+- let a = 0.5 in
>+- let b = 0.8 in
>+-
>+- let emittedBytes = ref 0. in
>+- let emitRate = ref 0. in
>+- let receivedBytes = ref 0. in
>+- let receiveRate = ref 0. in
>+-
>+- let stopCounter = ref 0 in
>+-
>+- let updateTable () =
>+- let row = rate_row in
>+- lst#set ~row ~column:c_client (rate2str !receiveRate2);
>+- lst#set ~row ~column:c_server (rate2str !emitRate2);
>+- lst#set ~row ~column:c_total (rate2str (!receiveRate2 +. !emitRate2));
>+- let row = receive_row in
>+- lst#set ~row ~column:c_client (kib2str !receivedBytes);
>+- lst#set ~row ~column:c_server (kib2str !emittedBytes);
>+- lst#set ~row ~column:c_total (kib2str (!receivedBytes +. !emittedBytes));
>+- let row = data_row in
>+- lst#set ~row ~column:c_client (kib2str !clientWritten);
>+- lst#set ~row ~column:c_server (kib2str !serverWritten);
>+- lst#set ~row ~column:c_total (kib2str (!clientWritten +. !serverWritten))
>+- in
>+- let timeout _ =
>+- emitRate :=
>+- a *. !emitRate +.
>+- (1. -. a) *. (!Remote.emittedBytes -. !emittedBytes) /. delay;
>+- emitRate2 :=
>+- b *. !emitRate2 +.
>+- (1. -. b) *. (!Remote.emittedBytes -. !emittedBytes) /. delay;
>+-(* emission#push !emitRate;*)
>+- receiveRate :=
>+- a *. !receiveRate +.
>+- (1. -. a) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;
>+- receiveRate2 :=
>+- b *. !receiveRate2 +.
>+- (1. -. b) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;
>+-(* reception#push !receiveRate;*)
>+- emittedBytes := !Remote.emittedBytes;
>+- receivedBytes := !Remote.receivedBytes;
>+- if !stopCounter > 0 then decr stopCounter;
>+- if !stopCounter = 0 then begin
>+- emitRate2 := 0.; receiveRate2 := 0.;
>+- end;
>+- updateTable ();
>+- !stopCounter <> 0
>+- in
>+- let startStats () =
>+- if !stopCounter = 0 then begin
>+- emittedBytes := !Remote.emittedBytes;
>+- receivedBytes := !Remote.receivedBytes;
>+- stopCounter := -1;
>+- ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.))
>+- ~callback:timeout)
>+- end else
>+- stopCounter := -1
>+- in
>+- let stopStats () = stopCounter := 10 in
>+- (t, startStats, stopStats)
>+-
>+-(* ------ *)
>+-
>+-let fatalError message =
>+- let () =
>+- try Trace.log (message ^ "\n")
>+- with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *)
>+- let title = "Fatal error" in
>+- let t =
>+- GWindow.dialog ~parent:(toplevelWindow ())
>+- ~border_width:6 ~modal:true ~resizable:false () in
>+- t#vbox#set_spacing 12;
>+- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+- ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG
>+- ~yalign:0. ~packing:h1#pack ());
>+- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>+- ignore (GMisc.label
>+- ~markup:(primaryText title ^ "\n\n" ^
>+- escapeMarkup (transcode message))
>+- ~line_wrap:true ~selectable:true ~yalign:0. ~packing:v1#add ());
>+- t#add_button_stock `QUIT `QUIT;
>+- t#set_default_response `QUIT;
>+- t#show(); ignore (t#run ()); t#destroy ();
>+- exit 1
>+-
>+-(* ------ *)
>+-
>+-let tryAgainOrQuit = fatalError
>+-
>+-(* ------ *)
>+-
>+-let getFirstRoot () =
>+- let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
>+- ~modal:true ~resizable:true () in
>+- t#misc#grab_focus ();
>+-
>+- let hb = GPack.hbox
>+- ~packing:(t#vbox#pack ~expand:false ~padding:15) () in
>+- ignore(GMisc.label ~text:tryAgainMessage
>+- ~justify:`LEFT
>+- ~packing:(hb#pack ~expand:false ~padding:15) ());
>+-
>+- let f1 = GPack.hbox ~spacing:4
>+- ~packing:(t#vbox#pack ~expand:true ~padding:4) () in
>+- ignore (GMisc.label ~text:"Dir:" ~packing:(f1#pack ~expand:false) ());
>+- let fileE = GEdit.entry ~packing:f1#add () in
>+- fileE#misc#grab_focus ();
>+- let b = GFile.chooser_button ~action:`SELECT_FOLDER
>+- ~title:"Select a local directory"
>+- ~packing:(f1#pack ~expand:false) () in
>+- ignore (b#connect#selection_changed ~callback:(fun () ->
>+- if not fileE#is_focus then
>+- fileE#set_text (match b#filename with None -> "" | Some s -> s)));
>+- ignore (fileE#connect#changed ~callback:(fun () ->
>+- if fileE#is_focus then ignore (b#set_filename fileE#text)));
>+-
>+- let f3 = t#action_area in
>+- let result = ref None in
>+- let contCommand() =
>+- result := Some(fileE#text);
>+- t#destroy () in
>+- let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in
>+- ignore (quitButton#connect#clicked
>+- ~callback:(fun () -> result := None; t#destroy()));
>+- let contButton = GButton.button ~stock:`OK ~packing:f3#add () in
>+- ignore (contButton#connect#clicked ~callback:contCommand);
>+- ignore (fileE#connect#activate ~callback:contCommand);
>+- contButton#grab_default ();
>+- t#show ();
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- GMain.Main.main ();
>+- match !result with None -> None
>+- | Some file ->
>+- Some(Clroot.clroot2string(Clroot.ConnectLocal(Some file)))
>+-
>+-(* ------ *)
>+-
>+-let getSecondRoot () =
>+- let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
>+- ~modal:true ~resizable:true () in
>+- t#misc#grab_focus ();
>+-
>+- let message = "Please enter the second directory you want to synchronize." in
>+-
>+- let vb = t#vbox in
>+- let hb = GPack.hbox ~packing:(vb#pack ~expand:false ~padding:15) () in
>+- ignore(GMisc.label ~text:message
>+- ~justify:`LEFT
>+- ~packing:(hb#pack ~expand:false ~padding:15) ());
>+- let helpB = GButton.button ~stock:`HELP ~packing:hb#add () in
>+- ignore (helpB#connect#clicked
>+- ~callback:(fun () -> okBox ~parent:t ~title:"Picking roots" ~typ:`INFO
>+- ~message:helpmessage));
>+-
>+- let result = ref None in
>+-
>+- let f = GPack.vbox ~packing:(vb#pack ~expand:false) () in
>+-
>+- let f1 = GPack.hbox ~spacing:4 ~packing:f#add () in
>+- ignore (GMisc.label ~text:"Directory:" ~packing:(f1#pack ~expand:false) ());
>+- let fileE = GEdit.entry ~packing:f1#add () in
>+- fileE#misc#grab_focus ();
>+- let b = GFile.chooser_button ~action:`SELECT_FOLDER
>+- ~title:"Select a local directory"
>+- ~packing:(f1#pack ~expand:false) () in
>+- ignore (b#connect#selection_changed ~callback:(fun () ->
>+- if not fileE#is_focus then
>+- fileE#set_text (match b#filename with None -> "" | Some s -> s)));
>+- ignore (fileE#connect#changed ~callback:(fun () ->
>+- if fileE#is_focus then ignore (b#set_filename fileE#text)));
>+-
>+- let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in
>+- let localB = GButton.radio_button ~packing:(f0#pack ~expand:false)
>+- ~label:"Local" () in
>+- let sshB = GButton.radio_button ~group:localB#group
>+- ~packing:(f0#pack ~expand:false)
>+- ~label:"SSH" () in
>+- let rshB = GButton.radio_button ~group:localB#group
>+- ~packing:(f0#pack ~expand:false) ~label:"RSH" () in
>+- let socketB = GButton.radio_button ~group:sshB#group
>+- ~packing:(f0#pack ~expand:false) ~label:"Socket" () in
>+-
>+- let f2 = GPack.hbox ~spacing:4 ~packing:f#add () in
>+- ignore (GMisc.label ~text:"Host:" ~packing:(f2#pack ~expand:false) ());
>+- let hostE = GEdit.entry ~packing:f2#add () in
>+-
>+- ignore (GMisc.label ~text:"(Optional) User:"
>+- ~packing:(f2#pack ~expand:false) ());
>+- let userE = GEdit.entry ~packing:f2#add () in
>+-
>+- ignore (GMisc.label ~text:"Port:"
>+- ~packing:(f2#pack ~expand:false) ());
>+- let portE = GEdit.entry ~packing:f2#add () in
>+-
>+- let varLocalRemote = ref (`Local : [`Local|`SSH|`RSH|`SOCKET]) in
>+- let localState() =
>+- varLocalRemote := `Local;
>+- hostE#misc#set_sensitive false;
>+- userE#misc#set_sensitive false;
>+- portE#misc#set_sensitive false;
>+- b#misc#set_sensitive true in
>+- let remoteState() =
>+- hostE#misc#set_sensitive true;
>+- b#misc#set_sensitive false;
>+- match !varLocalRemote with
>+- `SOCKET ->
>+- (portE#misc#set_sensitive true; userE#misc#set_sensitive false)
>+- | _ ->
>+- (portE#misc#set_sensitive false; userE#misc#set_sensitive true) in
>+- let protoState x =
>+- varLocalRemote := x;
>+- remoteState() in
>+- ignore (localB#connect#clicked ~callback:localState);
>+- ignore (sshB#connect#clicked ~callback:(fun () -> protoState(`SSH)));
>+- ignore (rshB#connect#clicked ~callback:(fun () -> protoState(`RSH)));
>+- ignore (socketB#connect#clicked ~callback:(fun () -> protoState(`SOCKET)));
>+- localState();
>+- let getRoot() =
>+- let file = fileE#text in
>+- let user = userE#text in
>+- let host = hostE#text in
>+- let port = portE#text in
>+- match !varLocalRemote with
>+- `Local ->
>+- Clroot.clroot2string(Clroot.ConnectLocal(Some file))
>+- | `SSH | `RSH ->
>+- Clroot.clroot2string(
>+- Clroot.ConnectByShell((if !varLocalRemote=`SSH then "ssh" else "rsh"),
>+- host,
>+- (if user="" then None else Some user),
>+- (if port="" then None else Some port),
>+- Some file))
>+- | `SOCKET ->
>+- Clroot.clroot2string(
>+- (* FIX: report an error if the port entry is not well formed *)
>+- Clroot.ConnectBySocket(host,
>+- portE#text,
>+- Some file)) in
>+- let contCommand() =
>+- try
>+- let root = getRoot() in
>+- result := Some root;
>+- t#destroy ()
>+- with Failure _ ->
>+- if portE#text="" then
>+- okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Please enter a port"
>+- else okBox ~parent:t ~title:"Error" ~typ:`ERROR
>+- ~message:"The port you specify must be an integer"
>+- | _ ->
>+- okBox ~parent:t ~title:"Error" ~typ:`ERROR
>+- ~message:"Something's wrong with the values you entered, try again" in
>+- let f3 = t#action_area in
>+- let quitButton =
>+- GButton.button ~stock:`QUIT ~packing:f3#add () in
>+- ignore (quitButton#connect#clicked ~callback:safeExit);
>+- let contButton =
>+- GButton.button ~stock:`OK ~packing:f3#add () in
>+- ignore (contButton#connect#clicked ~callback:contCommand);
>+- contButton#grab_default ();
>+- ignore (fileE#connect#activate ~callback:contCommand);
>+-
>+- t#show ();
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- GMain.Main.main ();
>+- !result
>+-
>+-(* ------ *)
>+-
>+-let getPassword rootName msg =
>+- let t =
>+- GWindow.dialog ~parent:(toplevelWindow ())
>+- ~title:"Unison: SSH connection" ~position:`CENTER
>+- ~modal:true ~resizable:false ~border_width:6 () in
>+- t#misc#grab_focus ();
>+-
>+- t#vbox#set_spacing 12;
>+-
>+- let header =
>+- primaryText
>+- (Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in
>+-
>+- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+- ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG
>+- ~yalign:0. ~packing:h1#pack ());
>+- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>+- ignore(GMisc.label ~markup:(header ^ "\n\n" ^
>+- escapeMarkup (Unicode.protect msg))
>+- ~selectable:true ~yalign:0. ~packing:v1#pack ());
>+-
>+- let passwordE = GEdit.entry ~packing:v1#pack ~visibility:false () in
>+- passwordE#misc#grab_focus ();
>+-
>+- t#add_button_stock `QUIT `QUIT;
>+- t#add_button_stock `OK `OK;
>+- t#set_default_response `OK;
>+- ignore (passwordE#connect#activate ~callback:(fun _ -> t#response `OK));
>+-
>+- t#show();
>+- let res = t#run () in
>+- let pwd = passwordE#text in
>+- t#destroy ();
>+- gtk_sync true;
>+- begin match res with
>+- `DELETE_EVENT | `QUIT -> safeExit (); ""
>+- | `OK -> pwd
>+- end
>+-
>+-let termInteract = Some getPassword
>+-
>+-(* ------ *)
>+-
>+-module React = struct
>+- type 'a t = { mutable state : 'a; mutable observers : ('a -> unit) list }
>+-
>+- let make v =
>+- let res = { state = v; observers = [] } in
>+- let update v =
>+- if res.state <> v then begin
>+- res.state <- v; List.iter (fun f -> f v) res.observers
>+- end
>+- in
>+- (res, update)
>+-
>+- let const v = fst (make v)
>+-
>+- let add_observer x f = x.observers <- f :: x.observers
>+-
>+- let state x = x.state
>+-
>+- let lift f x =
>+- let (res, update) = make (f (state x)) in
>+- add_observer x (fun v -> update (f v));
>+- res
>+-
>+- let lift2 f x y =
>+- let (res, update) = make (f (state x) (state y)) in
>+- add_observer x (fun v -> update (f v (state y)));
>+- add_observer y (fun v -> update (f (state x) v));
>+- res
>+-
>+- let lift3 f x y z =
>+- let (res, update) = make (f (state x) (state y) (state z)) in
>+- add_observer x (fun v -> update (f v (state y) (state z)));
>+- add_observer y (fun v -> update (f (state x) v (state z)));
>+- add_observer z (fun v -> update (f (state x) (state y) v));
>+- res
>+-
>+- let iter f x = f (state x); add_observer x f
>+-
>+- type 'a event = { mutable ev_observers : ('a -> unit) list }
>+-
>+- let make_event () =
>+- let res = { ev_observers = [] } in
>+- let trigger v = List.iter (fun f -> f v) res.ev_observers in
>+- (res, trigger)
>+-
>+- let add_ev_observer x f = x.ev_observers <- f :: x.ev_observers
>+-
>+- let hold v e =
>+- let (res, update) = make v in
>+- add_ev_observer e update;
>+- res
>+-
>+- let iter_ev f e = add_ev_observer e f
>+-
>+- let lift_ev f e =
>+- let (res, trigger) = make_event () in
>+- add_ev_observer e (fun x -> trigger (f x));
>+- res
>+-
>+- module Ops = struct
>+- let (>>) x f = lift f x
>+- let (>|) x f = iter f x
>+-
>+- let (>>>) x f = lift_ev f x
>+- let (>>|) x f = iter_ev f x
>+- end
>+-end
>+-
>+-module GtkReact = struct
>+- let entry (e : #GEdit.entry) =
>+- let (res, update) = React.make e#text in
>+- ignore (e#connect#changed ~callback:(fun () -> update (e#text)));
>+- res
>+-
>+- let text_combo ((c, _) : _ GEdit.text_combo) =
>+- let (res, update) = React.make c#active in
>+- ignore (c#connect#changed ~callback:(fun () -> update (c#active)));
>+- res
>+-
>+- let toggle_button (b : #GButton.toggle_button) =
>+- let (res, update) = React.make b#active in
>+- ignore (b#connect#toggled ~callback:(fun () -> update (b#active)));
>+- res
>+-
>+- let file_chooser (c : #GFile.chooser) =
>+- let (res, update) = React.make c#filename in
>+- ignore (c#connect#selection_changed
>+- ~callback:(fun () -> update (c#filename)));
>+- res
>+-
>+- let current_tree_view_selection (t : #GTree.view) =
>+- let m =t#model in
>+- Safelist.map (fun p -> m#get_row_reference p) t#selection#get_selected_rows
>+-
>+- let tree_view_selection_changed t =
>+- let (res, trigger) = React.make_event () in
>+- ignore (t#selection#connect#changed
>+- ~callback:(fun () -> trigger (current_tree_view_selection t)));
>+- res
>+-
>+- let tree_view_selection t =
>+- React.hold (current_tree_view_selection t) (tree_view_selection_changed t)
>+-
>+- let label (l : #GMisc.label) x = React.iter (fun v -> l#set_text v) x
>+-
>+- let label_underlined (l : #GMisc.label) x =
>+- React.iter (fun v -> l#set_text v; l#set_use_underline true) x
>+-
>+- let label_markup (l : #GMisc.label) x =
>+- React.iter (fun v -> l#set_text v; l#set_use_markup true) x
>+-
>+- let show w x =
>+- React.iter (fun b -> if b then w#misc#show () else w#misc#hide ()) x
>+- let set_sensitive w x = React.iter (fun b -> w#misc#set_sensitive b) x
>+-end
>+-
>+-open React.Ops
>+-
>+-(* ------ *)
>+-
>+-(* Resize an object (typically, a label with line wrapping) so that it
>+- use all its available space *)
>+-let adjustSize (w : #GObj.widget) =
>+- let notYet = ref true in
>+- ignore
>+- (w#misc#connect#size_allocate ~callback:(fun r ->
>+- if !notYet then begin
>+- notYet := false;
>+- (* JV: I have no idea where the 12 comes from. Without it,
>+- a window resize may happen. *)
>+- w#misc#set_size_request ~width:(max 10 (r.Gtk.width - 12)) ()
>+- end))
>+-
>+-let createProfile parent =
>+- let assistant = GAssistant.assistant ~modal:true () in
>+- assistant#set_transient_for parent#as_window;
>+- assistant#set_modal true;
>+- assistant#set_title "Profile Creation";
>+-
>+- let nonEmpty s = s <> "" in
>+-(*
>+- let integerRe =
>+- Str.regexp "\$[+-]?[0-9]+\\|0o[0-7]+\\|0x[0-9a-zA-Z]+\$" in
>+-*)
>+- let integerRe = Str.regexp "[0-9]+" in
>+- let isInteger s =
>+- Str.string_match integerRe s 0 && Str.matched_string s = s in
>+-
>+- (* Introduction *)
>+- let intro =
>+- GMisc.label
>+- ~xpad:12 ~ypad:12
>+- ~text:"Welcome to the Unison Profile Creation Assistant.\n\n\
>+- Click \"Next\" to begin."
>+- () in
>+- ignore
>+- (assistant#append_page
>+- ~title:"Profile Creation"
>+- ~page_type:`INTRO
>+- ~complete:true
>+- intro#as_widget);
>+-
>+- (* Profile name and description *)
>+- let description = GPack.vbox ~border_width:12 ~spacing:6 () in
>+- adjustSize
>+- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"Please enter the name of the profile and \
>+- possibly a short description."
>+- ~packing:(description#pack ~expand:false) ());
>+- let tbl =
>+- let al = GBin.alignment ~packing:(description#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>+- ~packing:(al#add) () in
>+- let nameEntry =
>+- GEdit.entry ~activates_default:true
>+- ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in
>+- let name = GtkReact.entry nameEntry in
>+- ignore (GMisc.label ~text:"Profile _name:" ~xalign:0.
>+- ~use_underline:true ~mnemonic_widget:nameEntry
>+- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>+- let labelEntry =
>+- GEdit.entry ~activates_default:true
>+- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in
>+- let label = GtkReact.entry labelEntry in
>+- ignore (GMisc.label ~text:"_Description:" ~xalign:0.
>+- ~use_underline:true ~mnemonic_widget:labelEntry
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>+- let existingProfileLabel =
>+- GMisc.label ~xalign:1. ~packing:(description#pack ~expand:false) ()
>+- in
>+- adjustSize existingProfileLabel;
>+- GtkReact.label_markup existingProfileLabel
>+- (name >> fun s -> Format.sprintf " Profile %s already exists."
>+- (escapeMarkup s));
>+- let profileExists =
>+- name >> fun s -> s <> "" && System.file_exists (Prefs.profilePathname s)
>+- in
>+- GtkReact.show existingProfileLabel profileExists;
>+-
>+- ignore
>+- (assistant#append_page
>+- ~title:"Profile Description"
>+- ~page_type:`CONTENT
>+- description#as_widget);
>+- let setPageComplete page b = assistant#set_page_complete page#as_widget b in
>+- React.lift2 (&&) (name >> nonEmpty) (profileExists >> not)
>+- >| setPageComplete description;
>+-
>+- let connection = GPack.vbox ~border_width:12 ~spacing:18 () in
>+- let al = GBin.alignment ~packing:(connection#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- let vb =
>+- GPack.vbox ~spacing:6 ~packing:(al#add) () in
>+- adjustSize
>+- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"You can use Unison to synchronize a local directory \
>+- with another local directory, or with a remote directory."
>+- ~packing:(vb#pack ~expand:false) ());
>+- adjustSize
>+- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"Please select the kind of synchronization \
>+- you want to perform."
>+- ~packing:(vb#pack ~expand:false) ());
>+- let tbl =
>+- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>+- ~packing:(al#add) () in
>+- ignore (GMisc.label ~text:"Description:" ~xalign:0. ~yalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>+- let kindCombo =
>+- let al =
>+- GBin.alignment ~xscale:0. ~xalign:0.
>+- ~packing:(tbl#attach ~left:1 ~top:0) () in
>+- GEdit.combo_box_text
>+- ~strings:["Local"; "Using SSH"; "Using RSH";
>+- "Through a plain TCP connection"]
>+- ~active:0 ~packing:(al#add) ()
>+- in
>+- ignore (GMisc.label ~text:"Synchronization _kind:" ~xalign:0.
>+- ~use_underline:true ~mnemonic_widget:(fst kindCombo)
>+- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>+- let kind =
>+- GtkReact.text_combo kindCombo
>+- >> fun i -> List.nth [`Local; `SSH; `RSH; `SOCKET] i
>+- in
>+- let isLocal = kind >> fun k -> k = `Local in
>+- let isSSH = kind >> fun k -> k = `SSH in
>+- let isSocket = kind >> fun k -> k = `SOCKET in
>+- let descrLabel =
>+- GMisc.label ~xalign:0. ~line_wrap:true
>+- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>+- in
>+- adjustSize descrLabel;
>+- GtkReact.label descrLabel
>+- (kind >> fun k ->
>+- match k with
>+- `Local ->
>+- "Local synchronization."
>+- | `SSH ->
>+- "This is the recommended way to synchronize \
>+- with a remote machine. A\xc2\xa0remote instance of Unison is \
>+- automatically started via SSH."
>+- | `RSH ->
>+- "Synchronization with a remote machine by starting \
>+- automatically a remote instance of Unison via RSH."
>+- | `SOCKET ->
>+- "Synchronization with a remote machine by connecting \
>+- to an instance of Unison already listening \
>+- on a specific TCP port.");
>+- let vb = GPack.vbox ~spacing:6 ~packing:(connection#add) () in
>+- GtkReact.show vb (isLocal >> not);
>+- ignore (GMisc.label ~markup:"Configuration" ~xalign:0.
>+- ~packing:(vb#pack ~expand:false) ());
>+- let al = GBin.alignment ~packing:(vb#add) () in
>+- al#set_left_padding 12;
>+- let vb = GPack.vbox ~spacing:6 ~packing:(al#add) () in
>+- let requirementLabel =
>+- GMisc.label ~xalign:0. ~line_wrap:true
>+- ~packing:(vb#pack ~expand:false) ()
>+- in
>+- adjustSize requirementLabel;
>+- GtkReact.label requirementLabel
>+- (kind >> fun k ->
>+- match k with
>+- `Local ->
>+- ""
>+- | `SSH ->
>+- "There must be an SSH client installed on this machine, \
>+- and Unison and an SSH server installed on the remote machine."
>+- | `RSH ->
>+- "There must be an RSH client installed on this machine, \
>+- and Unison and an RSH server installed on the remote machine."
>+- | `SOCKET ->
>+- "There must be a Unison server running on the remote machine, \
>+- listening on the port that you specify here. \
>+- (Use \"Unison -socket xxx\" on the remote machine to start \
>+- the Unison server.)");
>+- let connDescLabel =
>+- GMisc.label ~xalign:0. ~line_wrap:true
>+- ~packing:(vb#pack ~expand:false) ()
>+- in
>+- adjustSize connDescLabel;
>+- GtkReact.label connDescLabel
>+- (kind >> fun k ->
>+- match k with
>+- `Local -> ""
>+- | `SSH -> "Please enter the host to connect to and a user name, \
>+- if different from your user name on this machine."
>+- | `RSH -> "Please enter the host to connect to and a user name, \
>+- if different from your user name on this machine."
>+- | `SOCKET -> "Please enter the host and port to connect to.");
>+- let tbl =
>+- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>+- ~packing:(al#add) () in
>+- let hostEntry =
>+- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in
>+- let host = GtkReact.entry hostEntry in
>+- ignore (GMisc.label ~text:"_Host:" ~xalign:0.
>+- ~use_underline:true ~mnemonic_widget:hostEntry
>+- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>+- let userEntry =
>+- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>+- in
>+- GtkReact.show userEntry (isSocket >> not);
>+- let user = GtkReact.entry userEntry in
>+- GtkReact.show
>+- (GMisc.label ~text:"_User:" ~xalign:0. ~yalign:0.
>+- ~use_underline:true ~mnemonic_widget:userEntry
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ())
>+- (isSocket >> not);
>+- let portEntry =
>+- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>+- in
>+- GtkReact.show portEntry isSocket;
>+- let port = GtkReact.entry portEntry in
>+- GtkReact.show
>+- (GMisc.label ~text:"_Port:" ~xalign:0. ~yalign:0.
>+- ~use_underline:true ~mnemonic_widget:portEntry
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ())
>+- isSocket;
>+- let compressLabel =
>+- GMisc.label ~xalign:0. ~line_wrap:true
>+- ~text:"Data compression can greatly improve performance \
>+- on slow connections. However, it may slow down \
>+- things on (fast) local networks."
>+- ~packing:(vb#pack ~expand:false) ()
>+- in
>+- adjustSize compressLabel;
>+- GtkReact.show compressLabel isSSH;
>+- let compressButton =
>+- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- (GButton.check_button ~label:"Enable _compression" ~use_mnemonic:true
>+- ~active:true ~packing:(al#add) ())
>+- in
>+- GtkReact.show compressButton isSSH;
>+- let compress = GtkReact.toggle_button compressButton in
>+-(*XXX Disabled for now... *)
>+-(*
>+- adjustSize
>+- (GMisc.label ~xalign:0. ~line_wrap:true
>+- ~text:"If this is possible, it is recommended that Unison \
>+- attempts to connect immediately to the remote machine, \
>+- so that it can perform some auto-detections."
>+- ~packing:(vb#pack ~expand:false) ());
>+- let connectImmediately =
>+- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- GtkReact.toggle_button
>+- (GButton.check_button ~label:"Connect _immediately" ~use_mnemonic:true
>+- ~active:true ~packing:(al#add) ())
>+- in
>+- let connectImmediately =
>+- React.lift2 (&&) connectImmediately (isLocal >> not) in
>+-*)
>+- let pageComplete =
>+- React.lift2 (||) isLocal
>+- (React.lift2 (&&) (host >> nonEmpty)
>+- (React.lift2 (||) (isSocket >> not) (port >> isInteger)))
>+- in
>+- ignore
>+- (assistant#append_page
>+- ~title:"Connection Setup"
>+- ~page_type:`CONTENT
>+- connection#as_widget);
>+- pageComplete >| setPageComplete connection;
>+-
>+- (* Connection to server *)
>+-(*XXX Disabled for now... Fill in this page
>+- let connectionInProgress = GMisc.label ~text:"..." () in
>+- let p =
>+- assistant#append_page
>+- ~title:"Connecting to Server..."
>+- ~page_type:`PROGRESS
>+- connectionInProgress#as_widget
>+- in
>+- ignore
>+- (assistant#connect#prepare (fun () ->
>+- if assistant#current_page = p then begin
>+- if React.state connectImmediately then begin
>+- (* XXXX start connection... *)
>+- assistant#set_page_complete connectionInProgress#as_widget true
>+- end else
>+- assistant#set_current_page (p + 1)
>+- end));
>+-*)
>+-
>+- (* Directory selection *)
>+- let directorySelection = GPack.vbox ~border_width:12 ~spacing:6 () in
>+- adjustSize
>+- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"Please select the two directories that you want to synchronize."
>+- ~packing:(directorySelection#pack ~expand:false) ());
>+- let secondDirLabel1 =
>+- GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"The second directory is relative to your home \
>+- directory on the remote machine."
>+- ~packing:(directorySelection#pack ~expand:false) ()
>+- in
>+- adjustSize secondDirLabel1;
>+- GtkReact.show secondDirLabel1 ((React.lift2 (||) isLocal isSocket) >> not);
>+- let secondDirLabel2 =
>+- GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"The second directory is relative to \
>+- the working directory of the Unison server \
>+- running on the remote machine."
>+- ~packing:(directorySelection#pack ~expand:false) ()
>+- in
>+- adjustSize secondDirLabel2;
>+- GtkReact.show secondDirLabel2 isSocket;
>+- let tbl =
>+- let al =
>+- GBin.alignment ~packing:(directorySelection#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>+- ~packing:(al#add) () in
>+-(*XXX Should focus on this button when becomes visible... *)
>+- let firstDirButton =
>+- GFile.chooser_button ~action:`SELECT_FOLDER ~title:"First Directory"
>+- ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) ()
>+- in
>+- isLocal >| (fun b -> firstDirButton#set_title
>+- (if b then "First Directory" else "Local Directory"));
>+- GtkReact.label_underlined
>+- (GMisc.label ~xalign:0.
>+- ~mnemonic_widget:firstDirButton
>+- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ())
>+- (isLocal >> fun b ->
>+- if b then "_First directory:" else "_Local directory:");
>+- let noneToEmpty o = match o with None -> "" | Some s -> s in
>+- let firstDir = GtkReact.file_chooser firstDirButton >> noneToEmpty in
>+- let secondDirButton =
>+- GFile.chooser_button ~action:`SELECT_FOLDER ~title:"Second Directory"
>+- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in
>+- let secondDirLabel =
>+- GMisc.label ~xalign:0.
>+- ~text:"Se_cond directory:"
>+- ~use_underline:true ~mnemonic_widget:secondDirButton
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () in
>+- GtkReact.show secondDirButton isLocal;
>+- GtkReact.show secondDirLabel isLocal;
>+- let remoteDirEdit =
>+- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>+- in
>+- let remoteDirLabel =
>+- GMisc.label ~xalign:0.
>+- ~text:"_Remote directory:"
>+- ~use_underline:true ~mnemonic_widget:remoteDirEdit
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()
>+- in
>+- GtkReact.show remoteDirEdit (isLocal >> not);
>+- GtkReact.show remoteDirLabel (isLocal >> not);
>+- let secondDir =
>+- React.lift3 (fun b l r -> if b then l else r) isLocal
>+- (GtkReact.file_chooser secondDirButton >> noneToEmpty)
>+- (GtkReact.entry remoteDirEdit)
>+- in
>+- ignore
>+- (assistant#append_page
>+- ~title:"Directory Selection"
>+- ~page_type:`CONTENT
>+- directorySelection#as_widget);
>+- React.lift2 (||) (isLocal >> not) (React.lift2 (<>) firstDir secondDir)
>+- >| setPageComplete directorySelection;
>+-
>+- (* Specific options *)
>+- let options = GPack.vbox ~border_width:18 ~spacing:12 () in
>+- (* Do we need to set specific options for FAT partitions?
>+- If under Windows, then all the options are set properly, except for
>+- ignoreinodenumbers in case one replica is on a FAT partition on a
>+- remote non-Windows machine. As this is unlikely, we do not
>+- handle this case. *)
>+- let fat =
>+- if Util.osType = `Win32 then
>+- React.const false
>+- else begin
>+- let vb =
>+- GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in
>+- let fatLabel =
>+- GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"Select the following option if one of your \
>+- directory is on a FAT partition. This is typically \
>+- the case for a USB stick."
>+- ~packing:(vb#pack ~expand:false) ()
>+- in
>+- adjustSize fatLabel;
>+- let fatButton =
>+- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- (GButton.check_button
>+- ~label:"Synchronization involving a _FAT partition"
>+- ~use_mnemonic:true ~active:false ~packing:(al#add) ())
>+- in
>+- GtkReact.toggle_button fatButton
>+- end
>+- in
>+- (* Fastcheck is safe except on FAT partitions and on Windows when
>+- not in Unicode mode where there is a very slight chance of
>+- missing an update when a file is moved onto another with the same
>+- modification time. Nowadays, FAT is rarely used on working
>+- partitions. In most cases, we should be in Unicode mode.
>+- Thus, it seems sensible to always enable fastcheck. *)
>+-(*
>+- let fastcheck = isLocal >> not >> (fun b -> b || Util.osType = `Win32) in
>+-*)
>+- (* Unicode mode can be problematic when the source machine is under
>+- Windows and the remote machine is not, as Unison may have already
>+- been used using the legacy Latin 1 encoding. Cygwin also did not
>+- handle Unicode before version 1.7. *)
>+- let vb = GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in
>+- let askUnicode = React.const false in
>+-(* isLocal >> not >> fun b -> (b || Util.isCygwin) && Util.osType = `Win32 in*)
>+- GtkReact.show vb askUnicode;
>+- adjustSize
>+- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>+- ~text:"When synchronizing in case insensitive mode, \
>+- Unison has to make some assumptions regarding \
>+- filename encoding. If ensure, use Unicode."
>+- ~packing:(vb#pack ~expand:false) ());
>+- let vb =
>+- let al = GBin.alignment
>+- ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- GPack.vbox ~spacing:0 ~packing:(al#add) ()
>+- in
>+- ignore
>+- (GMisc.label ~xalign:0. ~text:"Filename encoding:"
>+- ~packing:(vb#pack ~expand:false) ());
>+- let hb =
>+- let al = GBin.alignment
>+- ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- GPack.button_box `VERTICAL ~layout:`START
>+- ~spacing:0 ~packing:(al#add) ()
>+- in
>+- let unicodeButton =
>+- GButton.radio_button ~label:"_Unicode" ~use_mnemonic:true ~active:true
>+- ~packing:(hb#add) ()
>+- in
>+- ignore
>+- (GButton.radio_button ~label:"_Latin 1" ~use_mnemonic:true
>+- ~group:unicodeButton#group ~packing:(hb#add) ());
>+-(*
>+- let unicode =
>+- React.lift2 (||) (askUnicode >> not) (GtkReact.toggle_button unicodeButton)
>+- in
>+-*)
>+- let p =
>+- assistant#append_page
>+- ~title:"Specific Options" ~complete:true
>+- ~page_type:`CONTENT
>+- options#as_widget
>+- in
>+- ignore
>+- (assistant#connect#prepare ~callback:(fun () ->
>+- if assistant#current_page = p &&
>+- not (Util.osType <> `Win32 || React.state askUnicode)
>+- then
>+- assistant#set_current_page (p + 1)));
>+-
>+- let conclusion =
>+- GMisc.label
>+- ~xpad:12 ~ypad:12
>+- ~text:"You have now finished filling in the profile.\n\n\
>+- Click \"Apply\" to create it."
>+- () in
>+- ignore
>+- (assistant#append_page
>+- ~title:"Done" ~complete:true
>+- ~page_type:`CONFIRM
>+- conclusion#as_widget);
>+-
>+- let profileName = ref None in
>+- let saveProfile () =
>+- let filename = Prefs.profilePathname (React.state name) in
>+- begin try
>+- let ch =
>+- System.open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename
>+- in
>+- Printf.fprintf ch "# Unison preferences\n";
>+- let label = React.state label in
>+- if label <> "" then Printf.fprintf ch "label = %s\n" label;
>+- Printf.fprintf ch "root = %s\n" (React.state firstDir);
>+- let secondDir = React.state secondDir in
>+- let host = React.state host in
>+- let user = match React.state user with "" -> None | u -> Some u in
>+- let secondRoot =
>+- match React.state kind with
>+- `Local -> Clroot.ConnectLocal (Some secondDir)
>+- | `SSH -> Clroot.ConnectByShell
>+- ("ssh", host, user, None, Some secondDir)
>+- | `RSH -> Clroot.ConnectByShell
>+- ("rsh", host, user, None, Some secondDir)
>+- | `SOCKET -> Clroot.ConnectBySocket
>+- (host, React.state port, Some secondDir)
>+- in
>+- Printf.fprintf ch "root = %s\n" (Clroot.clroot2string secondRoot);
>+- if React.state compress && React.state kind = `SSH then
>+- Printf.fprintf ch "sshargs = -C\n";
>+-(*
>+- if React.state fastcheck then
>+- Printf.fprintf ch "fastcheck = true\n";
>+- if React.state unicode then
>+- Printf.fprintf ch "unicode = true\n";
>+-*)
>+- if React.state fat then Printf.fprintf ch "fat = true\n";
>+- close_out ch;
>+- profileName := Some (React.state name)
>+- with Sys_error _ as e ->
>+- okBox ~parent:assistant ~typ:`ERROR ~title:"Could not save profile"
>+- ~message:(Uicommon.exn2string e)
>+- end;
>+- assistant#destroy ();
>+- in
>+- ignore (assistant#connect#close ~callback:saveProfile);
>+- ignore (assistant#connect#destroy ~callback:GMain.Main.quit);
>+- ignore (assistant#connect#cancel ~callback:assistant#destroy);
>+- assistant#show ();
>+- GMain.Main.main ();
>+- !profileName
>+-
>+-(* ------ *)
>+-
>+-let nameOfType t =
>+- match t with
>+- `BOOL -> "boolean"
>+- | `BOOLDEF -> "boolean"
>+- | `INT -> "integer"
>+- | `STRING -> "text"
>+- | `STRING_LIST -> "text list"
>+- | `CUSTOM -> "custom"
>+- | `UNKNOWN -> "unknown"
>+-
>+-let defaultValue t =
>+- match t with
>+- `BOOL -> ["true"]
>+- | `BOOLDEF -> ["true"]
>+- | `INT -> ["0"]
>+- | `STRING -> [""]
>+- | `STRING_LIST -> []
>+- | `CUSTOM -> []
>+- | `UNKNOWN -> []
>+-
>+-let editPreference parent nm ty vl =
>+- let t =
>+- GWindow.dialog ~parent ~border_width:12
>+- ~title:"Edit the Preference"
>+- ~modal:true () in
>+- let vb = t#vbox in
>+- vb#set_spacing 6;
>+-
>+- let isList =
>+- match ty with
>+- `STRING_LIST | `CUSTOM | `UNKNOWN -> true
>+- | _ -> false
>+- in
>+- let columns = if isList then 5 else 4 in
>+- let rows = if isList then 3 else 2 in
>+- let tbl =
>+- GPack.table ~rows ~columns ~col_spacings:12 ~row_spacings:6
>+- ~packing:(vb#pack ~expand:false) () in
>+- ignore (GMisc.label ~text:"Preference:" ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>+- ignore (GMisc.label ~text:"Description:" ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>+- ignore (GMisc.label ~text:"Type:" ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:2 ~expand:`NONE) ());
>+- ignore (GMisc.label ~text:(Unicode.protect nm) ~xalign:0. ~selectable:true ()
>+- ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X));
>+- let (doc, _, _) = Prefs.documentation nm in
>+- ignore (GMisc.label ~text:doc ~xalign:0. ~selectable:true ()
>+- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X));
>+- ignore (GMisc.label ~text:(nameOfType ty) ~xalign:0. ~selectable:true ()
>+- ~packing:(tbl#attach ~left:1 ~top:2 ~expand:`X));
>+- let newValue =
>+- if isList then begin
>+- let valueLabel =
>+- GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. ~yalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()
>+- in
>+- let cols = new GTree.column_list in
>+- let c_value = cols#add Gobject.Data.string in
>+- let c_ml = cols#add Gobject.Data.caml in
>+- let lst_store = GTree.list_store cols in
>+- let lst =
>+- let sw =
>+- GBin.scrolled_window ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X)
>+- ~shadow_type:`IN ~height:200 ~width:400
>+- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>+- GTree.view ~model:lst_store ~headers_visible:false
>+- ~reorderable:true ~packing:sw#add () in
>+- valueLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>+- let column =
>+- GTree.view_column
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) ()
>+- in
>+- ignore (lst#append_column column);
>+- let vb =
>+- GPack.button_box
>+- `VERTICAL ~layout:`START ~spacing:6
>+- ~packing:(tbl#attach ~left:2 ~top:3 ~expand:`NONE) ()
>+- in
>+- let selection = GtkReact.tree_view_selection lst in
>+- let hasSel = selection >> fun l -> l <> [] in
>+- let addB =
>+- GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in
>+- let removeB =
>+- GButton.button ~stock:`REMOVE ~packing:(vb#pack ~expand:false) () in
>+- let editB =
>+- GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in
>+- let upB =
>+- GButton.button ~stock:`GO_UP ~packing:(vb#pack ~expand:false) () in
>+- let downB =
>+- GButton.button ~stock:`GO_DOWN ~packing:(vb#pack ~expand:false) () in
>+- List.iter (fun b -> b#set_xalign 0.) [addB; removeB; editB; upB; downB];
>+- GtkReact.set_sensitive removeB hasSel;
>+- let editLabel =
>+- GMisc.label ~text:"Edited _item:"
>+- ~use_underline:true ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:4 ~expand:`NONE) ()
>+- in
>+- let editEntry =
>+- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:4 ~expand:`X) () in
>+- editLabel#set_mnemonic_widget (Some (editEntry :> GObj.widget));
>+- let edit = GtkReact.entry editEntry in
>+- let edited =
>+- React.lift2
>+- (fun l txt ->
>+- match l with
>+- [rf] -> lst_store#get ~row:rf#iter ~column:c_ml <> txt
>+- | _ -> false)
>+- selection edit
>+- in
>+- GtkReact.set_sensitive editB edited;
>+- let selectionChange = GtkReact.tree_view_selection_changed lst in
>+- selectionChange >>| (fun s ->
>+- match s with
>+- [rf] -> editEntry#set_text
>+- (lst_store#get ~row:rf#iter ~column:c_value)
>+- | _ -> ());
>+- let add () =
>+- let txt = editEntry#text in
>+- let row = lst_store#append () in
>+- lst_store#set ~row ~column:c_value txt;
>+- lst_store#set ~row ~column:c_ml txt;
>+- lst#selection#select_iter row;
>+- lst#scroll_to_cell (lst_store#get_path row) column
>+- in
>+- ignore (addB#connect#clicked ~callback:add);
>+- ignore (editEntry#connect#activate ~callback:add);
>+- let remove () =
>+- match React.state selection with
>+- [rf] -> let i = rf#iter in
>+- if lst_store#iter_next i then
>+- lst#selection#select_iter i
>+- else begin
>+- let p = rf#path in
>+- if GTree.Path.prev p then
>+- lst#selection#select_path p
>+- end;
>+- ignore (lst_store#remove rf#iter)
>+- | _ -> ()
>+- in
>+- ignore (removeB#connect#clicked ~callback:remove);
>+- let edit () =
>+- match React.state selection with
>+- [rf] -> let row = rf#iter in
>+- let txt = editEntry#text in
>+- lst_store#set ~row ~column:c_value txt;
>+- lst_store#set ~row ~column:c_ml txt
>+- | _ -> ()
>+- in
>+- ignore (editB#connect#clicked ~callback:edit);
>+- let updateUpDown l =
>+- let (upS, downS) =
>+- match l with
>+- [rf] -> (GTree.Path.prev rf#path, lst_store#iter_next rf#iter)
>+- | _ -> (false, false)
>+- in
>+- upB#misc#set_sensitive upS;
>+- downB#misc#set_sensitive downS
>+- in
>+- selectionChange >>| updateUpDown;
>+- ignore (lst_store#connect#after#row_deleted
>+- ~callback:(fun _ -> updateUpDown (React.state selection)));
>+- let go_up () =
>+- match React.state selection with
>+- [rf] -> let p = rf#path in
>+- if GTree.Path.prev p then begin
>+- let i = rf#iter in
>+- let i' = lst_store#get_iter p in
>+- ignore (lst_store#swap i i');
>+- lst#scroll_to_cell (lst_store#get_path i) column
>+- end;
>+- updateUpDown (React.state selection)
>+- | _ -> ()
>+- in
>+- ignore (upB#connect#clicked ~callback:go_up);
>+- let go_down () =
>+- match React.state selection with
>+- [rf] -> let i = rf#iter in
>+- if lst_store#iter_next i then begin
>+- let i' = rf#iter in
>+- ignore (lst_store#swap i i');
>+- lst#scroll_to_cell (lst_store#get_path i') column
>+- end;
>+- updateUpDown (React.state selection)
>+- | _ -> ()
>+- in
>+- ignore (downB#connect#clicked ~callback:go_down);
>+- List.iter
>+- (fun v ->
>+- let row = lst_store#append () in
>+- lst_store#set ~row ~column:c_value (Unicode.protect v);
>+- lst_store#set ~row ~column:c_ml v)
>+- vl;
>+- (fun () ->
>+- let l = ref [] in
>+- lst_store#foreach
>+- (fun _ row -> l := lst_store#get ~row ~column:c_ml :: !l; false);
>+- List.rev !l)
>+- end else begin
>+- let v = List.hd vl in
>+- begin match ty with
>+- `BOOL | `BOOLDEF ->
>+- let hb =
>+- GPack.button_box `HORIZONTAL ~layout:`START
>+- ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) ()
>+- in
>+- let isTrue = v = "true" || v = "yes" in
>+- let trueB =
>+- GButton.radio_button ~label:"_True" ~use_mnemonic:true
>+- ~active:isTrue ~packing:(hb#add) ()
>+- in
>+- ignore
>+- (GButton.radio_button ~label:"_False" ~use_mnemonic:true
>+- ~group:trueB#group ~active:(not isTrue) ~packing:(hb#add) ());
>+- ignore
>+- (GMisc.label ~text:"Value:" ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ());
>+- (fun () -> [if trueB#active then "true" else "false"])
>+- | `INT | `STRING ->
>+- let valueEntry =
>+- GEdit.entry ~text:v ~width_chars: 40
>+- ~activates_default:true
>+- ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) ()
>+- in
>+- ignore
>+- (GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0.
>+- ~mnemonic_widget:valueEntry
>+- ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ());
>+- (fun () -> [valueEntry#text])
>+- | `STRING_LIST | `CUSTOM | `UNKNOWN ->
>+- assert false
>+- end
>+- end
>+- in
>+-
>+- let res = ref None in
>+- let cancelCommand () = t#destroy () in
>+- let cancelButton =
>+- GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in
>+- ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>+- let okCommand _ = res := Some (newValue ()); t#destroy () in
>+- let okButton =
>+- GButton.button ~stock:`OK ~packing:t#action_area#add () in
>+- ignore (okButton#connect#clicked ~callback:okCommand);
>+- okButton#grab_default ();
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- t#show ();
>+- GMain.Main.main ();
>+- !res
>+-
>+-
>+-let markupRe = Str.regexp "<\$[a-z]+\$>\\|</\$[a-z]+\$>\\|&\$[a-z]+\$;"
>+-let entities =
>+- [("amp", "&"); ("lt", "<"); ("gt", ">"); ("quot", "\""); ("apos", "'")]
>+-
>+-let rec insertMarkupRec tags (t : #GText.view) s i tl =
>+- try
>+- let j = Str.search_forward markupRe s i in
>+- if j > i then
>+- t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i));
>+- let tag = try Some (Str.matched_group 1 s) with Not_found -> None in
>+- match tag with
>+- Some tag ->
>+- insertMarkupRec tags t s (Str.group_end 0)
>+- ((try [List.assoc tag tags] with Not_found -> []) :: tl)
>+- | None ->
>+- let entity = try Some (Str.matched_group 3 s) with Not_found -> None in
>+- match entity with
>+- None ->
>+- insertMarkupRec tags t s (Str.group_end 0) (List.tl tl)
>+- | Some ent ->
>+- begin try
>+- t#buffer#insert ~tags:(List.flatten tl) (List.assoc ent entities)
>+- with Not_found -> () end;
>+- insertMarkupRec tags t s (Str.group_end 0) tl
>+- with Not_found ->
>+- let j = String.length s in
>+- if j > i then
>+- t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i))
>+-
>+-let insertMarkup tags t s =
>+- t#buffer#set_text ""; insertMarkupRec tags t s 0 []
>+-
>+-let documentPreference ~compact ~packing =
>+- let vb = GPack.vbox ~spacing:6 ~packing () in
>+- ignore (GMisc.label ~markup:"Documentation" ~xalign:0.
>+- ~packing:(vb#pack ~expand:false) ());
>+- let al = GBin.alignment ~packing:(vb#pack ~expand:true ~fill:true) () in
>+- al#set_left_padding 12;
>+- let columns = if compact then 3 else 2 in
>+- let tbl =
>+- GPack.table ~rows:2 ~columns ~col_spacings:12 ~row_spacings:6
>+- ~packing:(al#add) () in
>+- tbl#misc#set_sensitive false;
>+- ignore (GMisc.label ~text:"Short description:" ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>+- ignore (GMisc.label ~text:"Long description:" ~xalign:0. ~yalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>+- let shortDescr =
>+- GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)
>+- ~xalign:0. ~selectable:true () in
>+- let longDescr =
>+- let sw =
>+- if compact then
>+- GBin.scrolled_window ~height:128 ~width:640
>+- ~packing:(tbl#attach ~left:0 ~top:2 ~right:2 ~expand:`BOTH)
>+- ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
>+- else
>+- GBin.scrolled_window ~height:128 ~width:640
>+- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`BOTH)
>+- ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
>+- in
>+- GText.view ~editable:false ~packing:sw#add ~wrap_mode:`WORD ()
>+- in
>+- let (>>>) x f = f x in
>+- let newlineRe = Str.regexp "\n *" in
>+- let styleRe = Str.regexp "{\\\\\$[a-z]+\$ \$[^{}]*\$}" in
>+- let verbRe = Str.regexp "\\\\verb|\$[^|]*\$|" in
>+- let argRe = Str.regexp "\\\\ARG{\$[^{}]*\$}" in
>+- let textttRe = Str.regexp "\\\\texttt{\$[^{}]*\$}" in
>+- let emphRe = Str.regexp "\\\\emph{\$[^{}]*\$}" in
>+- let sectionRe = Str.regexp "\\\\sectionref{\$[^{}]*\$}{\$[^{}]*\$}" in
>+- let emdash = Str.regexp_string "---" in
>+- let parRe = Str.regexp "\\\\par *" in
>+- let underRe = Str.regexp "\\\\_ *" in
>+- let dollarRe = Str.regexp "\\\\\\$ *" in
>+- let formatDoc doc =
>+- doc >>>
>+- Str.global_replace newlineRe " " >>>
>+- escapeMarkup >>>
>+- Str.global_substitute styleRe
>+- (fun s ->
>+- try
>+- let tag =
>+- match Str.matched_group 1 s with
>+- "em" -> "i"
>+- | "tt" -> "tt"
>+- | _ -> raise Exit
>+- in
>+- Format.sprintf "<%s>%s</%s>" tag (Str.matched_group 2 s) tag
>+- with Exit ->
>+- Str.matched_group 0 s) >>>
>+- Str.global_replace verbRe "<tt>\\1</tt>" >>>
>+- Str.global_replace argRe "<tt>\\1</tt>" >>>
>+- Str.global_replace textttRe "<tt>\\1</tt>" >>>
>+- Str.global_replace emphRe "\\1" >>>
>+- Str.global_replace sectionRe "Section '\\2'" >>>
>+- Str.global_replace emdash "\xe2\x80\x94" >>>
>+- Str.global_replace parRe "\n" >>>
>+- Str.global_replace underRe "_" >>>
>+- Str.global_replace dollarRe "_"
>+- in
>+- let tags =
>+- let create = longDescr#buffer#create_tag in
>+- [("i", create [`FONT_DESC (Lazy.force fontItalic)]);
>+- ("tt", create [`FONT_DESC (Lazy.force fontMonospace)])]
>+- in
>+- fun nm ->
>+- let (short, long, _) =
>+- match nm with
>+- Some nm ->
>+- tbl#misc#set_sensitive true;
>+- Prefs.documentation nm
>+- | _ ->
>+- tbl#misc#set_sensitive false;
>+- ("", "", false)
>+- in
>+- shortDescr#set_text (String.capitalize_ascii short);
>+- insertMarkup tags longDescr (formatDoc long)
>+-(* longDescr#buffer#set_text (formatDoc long)*)
>+-
>+-let addPreference parent =
>+- let t =
>+- GWindow.dialog ~parent ~border_width:12
>+- ~title:"Add a Preference"
>+- ~modal:true () in
>+- let vb = t#vbox in
>+-(* vb#set_spacing 18;*)
>+- let paned = GPack.paned `VERTICAL ~packing:vb#add () in
>+-
>+- let lvb = GPack.vbox ~spacing:6 ~packing:paned#pack1 () in
>+- let preferenceLabel =
>+- GMisc.label
>+- ~text:"_Preferences:" ~use_underline:true
>+- ~xalign:0. ~packing:(lvb#pack ~expand:false) ()
>+- in
>+- let cols = new GTree.column_list in
>+- let c_name = cols#add Gobject.Data.string in
>+- let basic_store = GTree.list_store cols in
>+- let full_store = GTree.list_store cols in
>+- let lst =
>+- let sw =
>+- GBin.scrolled_window ~packing:(lvb#pack ~expand:true)
>+- ~shadow_type:`IN ~height:200 ~width:400
>+- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>+- GTree.view ~headers_visible:false ~packing:sw#add () in
>+- preferenceLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>+- ignore (lst#append_column
>+- (GTree.view_column
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) ()));
>+- let hiddenPrefs =
>+- ["auto"; "doc"; "silent"; "terse"; "testserver"; "version"] in
>+- let shownPrefs =
>+- ["label"; "key"] in
>+- let insert (store : #GTree.list_store) all =
>+- List.iter
>+- (fun nm ->
>+- if
>+- all || List.mem nm shownPrefs ||
>+- (let (_, _, basic) = Prefs.documentation nm in basic &&
>+- not (List.mem nm hiddenPrefs))
>+- then begin
>+- let row = store#append () in
>+- store#set ~row ~column:c_name nm
>+- end)
>+- (Prefs.list ())
>+- in
>+- insert basic_store false;
>+- insert full_store true;
>+-
>+- let showAll =
>+- GtkReact.toggle_button
>+- (GButton.check_button ~label:"_Show all preferences"
>+- ~use_mnemonic:true ~active:false ~packing:(lvb#pack ~expand:false) ())
>+- in
>+- showAll >|
>+- (fun b ->
>+- lst#set_model
>+- (Some (if b then full_store else basic_store :> GTree.model)));
>+-
>+- let selection = GtkReact.tree_view_selection lst in
>+- let updateDoc = documentPreference ~compact:true ~packing:paned#pack2 in
>+- selection >|
>+- (fun l ->
>+- let nm =
>+- match l with
>+- [rf] ->
>+- let row = rf#iter in
>+- let store =
>+- if React.state showAll then full_store else basic_store in
>+- Some (store#get ~row ~column:c_name)
>+- | _ ->
>+- None
>+- in
>+- updateDoc nm);
>+-
>+- let cancelCommand () = t#destroy () in
>+- let cancelButton =
>+- GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in
>+- ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>+- ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true));
>+- let ok = ref false in
>+- let addCommand _ = ok := true; t#destroy () in
>+- let addButton =
>+- GButton.button ~stock:`ADD ~packing:t#action_area#add () in
>+- ignore (addButton#connect#clicked ~callback:addCommand);
>+- GtkReact.set_sensitive addButton (selection >> fun l -> l <> []);
>+- ignore (lst#connect#row_activated ~callback:(fun _ _ -> addCommand ()));
>+- addButton#grab_default ();
>+-
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- t#show ();
>+- GMain.Main.main ();
>+- if not !ok then None else
>+- match React.state selection with
>+- [rf] ->
>+- let row = rf#iter in
>+- let store =
>+- if React.state showAll then full_store else basic_store in
>+- Some (store#get ~row ~column:c_name)
>+- | _ ->
>+- None
>+-
>+-let editProfile parent name =
>+- let t =
>+- GWindow.dialog ~parent ~border_width:12
>+- ~title:(Format.sprintf "%s - Profile Editor" name)
>+- ~modal:true () in
>+- let vb = t#vbox in
>+-(* t#vbox#set_spacing 18;*)
>+- let paned = GPack.paned `VERTICAL ~packing:vb#add () in
>+-
>+- let lvb = GPack.vbox ~spacing:6 ~packing:paned#pack1 () in
>+- let preferenceLabel =
>+- GMisc.label
>+- ~text:"_Preferences:" ~use_underline:true
>+- ~xalign:0. ~packing:(lvb#pack ~expand:false) ()
>+- in
>+- let hb = GPack.hbox ~spacing:12 ~packing:(lvb#add) () in
>+- let cols = new GTree.column_list in
>+- let c_name = cols#add Gobject.Data.string in
>+- let c_type = cols#add Gobject.Data.string in
>+- let c_value = cols#add Gobject.Data.string in
>+- let c_ml = cols#add Gobject.Data.caml in
>+- let lst_store = GTree.list_store cols in
>+- let lst_sorted_store = GTree.model_sort lst_store in
>+- lst_sorted_store#set_sort_column_id 0 `ASCENDING;
>+- let lst =
>+- let sw =
>+- GBin.scrolled_window ~packing:(hb#pack ~expand:true)
>+- ~shadow_type:`IN ~height:300 ~width:600
>+- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>+- GTree.view ~model:lst_sorted_store ~packing:sw#add
>+- ~headers_clickable:true () in
>+- preferenceLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>+- let vc_name =
>+- GTree.view_column
>+- ~title:"Name"
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) () in
>+- vc_name#set_sort_column_id 0;
>+- ignore (lst#append_column vc_name);
>+- ignore (lst#append_column
>+- (GTree.view_column
>+- ~title:"Type"
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_type]) ()));
>+- ignore (lst#append_column
>+- (GTree.view_column
>+- ~title:"Value"
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) ()));
>+- let vb =
>+- GPack.button_box
>+- `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) ()
>+- in
>+- let selection = GtkReact.tree_view_selection lst in
>+- let hasSel = selection >> fun l -> l <> [] in
>+- let addB =
>+- GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in
>+- let editB =
>+- GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in
>+- let deleteB =
>+- GButton.button ~stock:`DELETE ~packing:(vb#pack ~expand:false) () in
>+- List.iter (fun b -> b#set_xalign 0.) [addB; editB; deleteB];
>+- GtkReact.set_sensitive editB hasSel;
>+- GtkReact.set_sensitive deleteB hasSel;
>+-
>+- let (modified, setModified) = React.make false in
>+- let formatValue vl = Unicode.protect (String.concat ", " vl) in
>+- let deletePref () =
>+- match React.state selection with
>+- [rf] ->
>+- let row = lst_sorted_store#convert_iter_to_child_iter rf#iter in
>+- let (nm, ty, vl) = lst_store#get ~row ~column:c_ml in
>+- if
>+- twoBox ~kind:`DIALOG_QUESTION ~parent:t ~title:"Preference Deletion"
>+- ~bstock:`CANCEL ~astock:`DELETE
>+- (Format.sprintf "Do you really want to delete preference %s?"
>+- (Unicode.protect nm))
>+- then begin
>+- ignore (lst_store#remove row);
>+- setModified true
>+- end
>+- | _ ->
>+- ()
>+- in
>+- let editPref path =
>+- let row =
>+- lst_sorted_store#convert_iter_to_child_iter
>+- (lst_sorted_store#get_iter path) in
>+- let (nm, ty, vl) = lst_store#get ~row ~column:c_ml in
>+- match editPreference t nm ty vl with
>+- Some [] ->
>+- deletePref ()
>+- | Some vl' when vl <> vl' ->
>+- lst_store#set ~row ~column:c_ml (nm, ty, vl');
>+- lst_store#set ~row ~column:c_value (formatValue vl');
>+- setModified true
>+- | _ ->
>+- ()
>+- in
>+- let add () =
>+- match addPreference t with
>+- None ->
>+- ()
>+- | Some nm ->
>+- let existing = ref false in
>+- lst_store#foreach
>+- (fun path row ->
>+- let (nm', _, _) = lst_store#get ~row ~column:c_ml in
>+- if nm = nm' then begin
>+- existing := true; editPref path; true
>+- end else
>+- false);
>+- if not !existing then begin
>+- let ty = Prefs.typ nm in
>+- match editPreference parent nm ty (defaultValue ty) with
>+- Some vl when vl <> [] ->
>+- let row = lst_store#append () in
>+- lst_store#set ~row ~column:c_name (Unicode.protect nm);
>+- lst_store#set ~row ~column:c_type (nameOfType ty);
>+- lst_store#set ~row ~column:c_ml (nm, ty, vl);
>+- lst_store#set ~row ~column:c_value (formatValue vl);
>+- setModified true
>+- | _ ->
>+- ()
>+- end
>+- in
>+- ignore (addB#connect#clicked ~callback:add);
>+- ignore (editB#connect#clicked
>+- ~callback:(fun () ->
>+- match React.state selection with
>+- [p] -> editPref p#path
>+- | _ -> ()));
>+- ignore (deleteB#connect#clicked ~callback:deletePref);
>+-
>+- let updateDoc = documentPreference ~compact:true ~packing:paned#pack2 in
>+- selection >|
>+- (fun l ->
>+- let nm =
>+- match l with
>+- [rf] ->
>+- let row = rf#iter in
>+- Some (lst_sorted_store#get ~row ~column:c_name)
>+- | _ ->
>+- None
>+- in
>+- updateDoc nm);
>+- ignore (lst#connect#row_activated ~callback:(fun path _ -> editPref path));
>+-
>+- let group l =
>+- let rec groupRec l k vl l' =
>+- match l with
>+- (k', v) :: r ->
>+- if k = k' then
>+- groupRec r k (v :: vl) l'
>+- else
>+- groupRec r k' [v] ((k, vl) :: l')
>+- | [] ->
>+- Safelist.fold_left
>+- (fun acc (k, l) -> (k, List.rev l) :: acc) [] ((k, vl) :: l')
>+- in
>+- match l with
>+- (k, v) :: r -> groupRec r k [v] []
>+- | [] -> []
>+- in
>+- let lastOne l = [List.hd (Safelist.rev l)] in
>+- let normalizeValue t vl =
>+- match t with
>+- `BOOL | `INT | `STRING -> lastOne vl
>+- | `STRING_LIST | `CUSTOM | `UNKNOWN -> vl
>+- | `BOOLDEF ->
>+- let l = lastOne vl in
>+- if l = ["default"] || l = ["auto"] then [] else l
>+- in
>+- let (>>>) x f = f x in
>+- Prefs.readAFile name
>+- >>> List.map (fun (_, _, nm, v) -> Prefs.canonicalName nm, v)
>+- >>> List.stable_sort (fun (nm, _) (nm', _) -> compare nm nm')
>+- >>> group
>+- >>> List.iter
>+- (fun (nm, vl) ->
>+- let nm = Prefs.canonicalName nm in
>+- let ty = Prefs.typ nm in
>+- let vl = normalizeValue ty vl in
>+- if vl <> [] then begin
>+- let row = lst_store#append () in
>+- lst_store#set ~row ~column:c_name (Unicode.protect nm);
>+- lst_store#set ~row ~column:c_type (nameOfType ty);
>+- lst_store#set ~row ~column:c_value (formatValue vl);
>+- lst_store#set ~row ~column:c_ml (nm, ty, vl)
>+- end);
>+-
>+- let applyCommand _ =
>+- if React.state modified then begin
>+- let filename = Prefs.profilePathname name in
>+- try
>+- let ch =
>+- System.open_out_gen [Open_wronly; Open_creat; Open_trunc] 0o600
>+- filename
>+- in
>+- (*XXX Should trim whitespaces and check for '\n' at some point *)
>+- Printf.fprintf ch "# Unison preferences\n";
>+- lst_store#foreach
>+- (fun path row ->
>+- let (nm, _, vl) = lst_store#get ~row ~column:c_ml in
>+- List.iter (fun v -> Printf.fprintf ch "%s = %s\n" nm v) vl;
>+- false);
>+- close_out ch;
>+- setModified false
>+- with Sys_error _ as e ->
>+- okBox ~parent:t ~typ:`ERROR ~title:"Could not save profile"
>+- ~message:(Uicommon.exn2string e)
>+- end
>+- in
>+- let applyButton =
>+- GButton.button ~stock:`APPLY ~packing:t#action_area#add () in
>+- ignore (applyButton#connect#clicked ~callback:applyCommand);
>+- GtkReact.set_sensitive applyButton modified;
>+- let cancelCommand () = t#destroy () in
>+- let cancelButton =
>+- GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in
>+- ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>+- ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true));
>+- let okCommand _ = applyCommand (); t#destroy () in
>+- let okButton =
>+- GButton.button ~stock:`OK ~packing:t#action_area#add () in
>+- ignore (okButton#connect#clicked ~callback:okCommand);
>+- okButton#grab_default ();
>+-(*
>+-List.iter
>+- (fun (nm, _, long) ->
>+- try
>+- let long = formatDoc long in
>+- ignore (Str.search_forward (Str.regexp_string "\\") long 0);
>+- Format.eprintf "%s %s@." nm long
>+- with Not_found -> ())
>+-(Prefs.listVisiblePrefs ());
>+-*)
>+-
>+-(*
>+-TODO:
>+- - Extra tabs for common preferences
>+- (should keep track of any change, or blacklist some preferences)
>+- - Add, modify, delete
>+- - Keep track of whether there is any change (apply button)
>+-*)
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- t#show ();
>+- GMain.Main.main ()
>+-
>+-(* ------ *)
>+-
>+-let getProfile quit =
>+- let ok = ref false in
>+-
>+- (* Build the dialog *)
>+- let t =
>+- GWindow.dialog ~parent:(toplevelWindow ()) ~border_width:12
>+- ~title:"Profile Selection"
>+- ~modal:true () in
>+- t#set_default_width 550;
>+-
>+- let cancelCommand _ = t#destroy () in
>+- let cancelButton =
>+- GButton.button ~stock:(if quit then `QUIT else `CANCEL)
>+- ~packing:t#action_area#add () in
>+- ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>+- ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true));
>+- cancelButton#misc#set_can_default true;
>+-
>+- let okCommand() = ok := true; t#destroy () in
>+- let okButton =
>+- GButton.button ~stock:`OPEN ~packing:t#action_area#add () in
>+- ignore (okButton#connect#clicked ~callback:okCommand);
>+- okButton#misc#set_sensitive false;
>+- okButton#grab_default ();
>+-
>+- let vb = t#vbox in
>+- t#vbox#set_spacing 18;
>+-
>+- let al = GBin.alignment ~packing:(vb#add) () in
>+- al#set_left_padding 12;
>+-
>+- let lvb = GPack.vbox ~spacing:6 ~packing:(al#add) () in
>+- let selectLabel =
>+- GMisc.label
>+- ~text:"Select a _profile:" ~use_underline:true
>+- ~xalign:0. ~packing:(lvb#pack ~expand:false) ()
>+- in
>+- let hb = GPack.hbox ~spacing:12 ~packing:(lvb#add) () in
>+- let sw =
>+- GBin.scrolled_window ~packing:(hb#pack ~expand:true) ~height:300
>+- ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>+- let cols = new GTree.column_list in
>+- let c_name = cols#add Gobject.Data.string in
>+- let c_label = cols#add Gobject.Data.string in
>+- let c_ml = cols#add Gobject.Data.caml in
>+- let lst_store = GTree.list_store cols in
>+- let lst = GTree.view ~model:lst_store ~packing:sw#add () in
>+- selectLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>+- let vc_name =
>+- GTree.view_column
>+- ~title:"Profile"
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) ()
>+- in
>+- ignore (lst#append_column vc_name);
>+- ignore (lst#append_column
>+- (GTree.view_column
>+- ~title:"Description"
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_label]) ()));
>+-
>+- let vb = GPack.vbox ~spacing:6 ~packing:(vb#pack ~expand:false) () in
>+- ignore (GMisc.label ~markup:"Summary" ~xalign:0.
>+- ~packing:(vb#pack ~expand:false) ());
>+- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>+- al#set_left_padding 12;
>+- let tbl =
>+- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>+- ~packing:(al#add) () in
>+- tbl#misc#set_sensitive false;
>+- ignore (GMisc.label ~text:"First root:" ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>+- ignore (GMisc.label ~text:"Second root:" ~xalign:0.
>+- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>+- let root1 =
>+- GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)
>+- ~xalign:0. ~selectable:true () in
>+- let root2 =
>+- GMisc.label ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X)
>+- ~xalign:0. ~selectable:true () in
>+-
>+- let fillLst default =
>+- Uicommon.scanProfiles();
>+- lst_store#clear ();
>+- Safelist.iter
>+- (fun (profile, info) ->
>+- let labeltext =
>+- match info.Uicommon.label with None -> "" | Some l -> l in
>+- let row = lst_store#append () in
>+- lst_store#set ~row ~column:c_name (Unicode.protect profile);
>+- lst_store#set ~row ~column:c_label (Unicode.protect labeltext);
>+- lst_store#set ~row ~column:c_ml (profile, info);
>+- if Some profile = default then begin
>+- lst#selection#select_iter row;
>+- lst#scroll_to_cell (lst_store#get_path row) vc_name
>+- end)
>+- (Safelist.sort (fun (p, _) (p', _) -> compare p p') !Uicommon.profilesAndRoots)
>+- in
>+- let selection = GtkReact.tree_view_selection lst in
>+- let hasSel = selection >> fun l -> l <> [] in
>+- let selInfo =
>+- selection >> fun l ->
>+- match l with
>+- [rf] -> Some (lst_store#get ~row:rf#iter ~column:c_ml, rf)
>+- | _ -> None
>+- in
>+- selInfo >|
>+- (fun info ->
>+- match info with
>+- Some ((profile, info), _) ->
>+- begin match info.Uicommon.roots with
>+- [r1; r2] -> root1#set_text (Unicode.protect r1);
>+- root2#set_text (Unicode.protect r2);
>+- tbl#misc#set_sensitive true
>+- | _ -> root1#set_text ""; root2#set_text "";
>+- tbl#misc#set_sensitive false
>+- end
>+- | None ->
>+- root1#set_text ""; root2#set_text "";
>+- tbl#misc#set_sensitive false);
>+- GtkReact.set_sensitive okButton hasSel;
>+-
>+- let vb =
>+- GPack.button_box
>+- `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) ()
>+- in
>+- let addButton =
>+- GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in
>+- ignore (addButton#connect#clicked
>+- ~callback:(fun () ->
>+- match createProfile t with
>+- Some p -> fillLst (Some p) | None -> ()));
>+- let editButton =
>+- GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in
>+- ignore (editButton#connect#clicked
>+- ~callback:(fun () -> match React.state selInfo with
>+- None ->
>+- ()
>+- | Some ((p, _), _) ->
>+- editProfile t p; fillLst (Some p)));
>+- GtkReact.set_sensitive editButton hasSel;
>+- let deleteProfile () =
>+- match React.state selInfo with
>+- Some ((profile, _), rf) ->
>+- if
>+- twoBox ~kind:`DIALOG_QUESTION ~parent:t ~title:"Profile Deletion"
>+- ~bstock:`CANCEL ~astock:`DELETE
>+- (Format.sprintf "Do you really want to delete profile %s?"
>+- (transcode profile))
>+- then begin
>+- try
>+- System.unlink (Prefs.profilePathname profile);
>+- ignore (lst_store#remove rf#iter)
>+- with Unix.Unix_error _ -> ()
>+- end
>+- | None ->
>+- ()
>+- in
>+- let deleteButton =
>+- GButton.button ~stock:`DELETE ~packing:(vb#pack ~expand:false) () in
>+- ignore (deleteButton#connect#clicked ~callback:deleteProfile);
>+- GtkReact.set_sensitive deleteButton hasSel;
>+- List.iter (fun b -> b#set_xalign 0.) [addButton; editButton; deleteButton];
>+-
>+- ignore (lst#connect#row_activated ~callback:(fun _ _ -> okCommand ()));
>+- fillLst None;
>+- lst#misc#grab_focus ();
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- t#show ();
>+- GMain.Main.main ();
>+- match React.state selInfo with
>+- Some ((p, _), _) when !ok -> Some p
>+- | _ -> None
>+-
>+-(* ------ *)
>+-
>+-let documentation sect =
>+- let title = "Documentation" in
>+- let t = GWindow.dialog ~title () in
>+- let t_dismiss =
>+- GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
>+- t_dismiss#grab_default ();
>+- let dismiss () = t#destroy () in
>+- ignore (t_dismiss#connect#clicked ~callback:dismiss);
>+- ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));
>+-
>+- let (name, docstr) = Safelist.assoc sect Strings.docs in
>+- let hb = GPack.hbox ~packing:(t#vbox#pack ~expand:false ~padding:2) () in
>+-
>+- let t_text =
>+- new scrolled_text ~editable:false
>+- ~width:80 ~height:20 ~packing:(t#vbox#pack ~expand:true) ()
>+- in
>+- t_text#insert docstr;
>+-
>+- let menuBar =
>+- GMenu.menu_bar ~border_width:0
>+- ~packing:(hb#pack ~expand:true ~fill:false) () in
>+- let mi = GMenu.menu_item ~label:"Topics" () in
>+- menuBar#insert mi 0;
>+-
>+- let sect_idx = ref 0 in
>+- let idx = ref 0 in
>+- let menu = GMenu.menu ~packing:(mi#set_submenu) () in
>+- let addDocSection (shortname, (name, docstr)) =
>+- if shortname <> "" && name <> "" then begin
>+- if shortname = sect then sect_idx := !idx;
>+- incr idx;
>+- let item = GMenu.menu_item ~label:name ~packing:menu#append () in
>+- ignore
>+- (item#connect#activate ~callback:(fun () -> t_text#insert docstr))
>+- end
>+- in
>+- Safelist.iter addDocSection Strings.docs;
>+-
>+- t#show ()
>+-
>+-(* ------ *)
>+-
>+-let messageBox ~title ?(action = fun t -> t#destroy) message =
>+- let utitle = transcode title in
>+- let t = GWindow.dialog ~title:utitle ~position:`CENTER () in
>+- let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
>+- t_dismiss#grab_default ();
>+- ignore (t_dismiss#connect#clicked ~callback:(action t));
>+- let t_text =
>+- new scrolled_text ~editable:false
>+- ~width:80 ~height:20 ~packing:t#vbox#add ()
>+- in
>+- t_text#insert message;
>+- ignore (t#event#connect#delete ~callback:(fun _ -> action t (); true));
>+- t#show ()
>+-
>+-(* twoBoxAdvanced: Display a message in a window and wait for the user
>+- to hit one of two buttons. Return true if the first button is
>+- chosen, false if the second button is chosen. Also has a button for
>+- showing more details to the user in a messageBox dialog *)
>+-let twoBoxAdvanced
>+- ~parent ~title ~message ~longtext ~advLabel ~astock ~bstock =
>+- let t =
>+- GWindow.dialog ~parent ~border_width:6 ~modal:true
>+- ~resizable:false () in
>+- t#vbox#set_spacing 12;
>+- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+- ignore (GMisc.image ~stock:`DIALOG_QUESTION ~icon_size:`DIALOG
>+- ~yalign:0. ~packing:h1#pack ());
>+- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>+- ignore (GMisc.label
>+- ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)
>+- ~selectable:true ~yalign:0. ~packing:v1#add ());
>+- t#add_button_stock `CANCEL `NO;
>+- let cmd () =
>+- messageBox ~title:"Details" longtext
>+- in
>+- t#add_button advLabel `HELP;
>+- t#add_button_stock `APPLY `YES;
>+- t#set_default_response `NO;
>+- let res = ref false in
>+- let setRes signal =
>+- match signal with
>+- `YES -> res := true; t#destroy ()
>+- | `NO -> res := false; t#destroy ()
>+- | `HELP -> cmd ()
>+- | _ -> ()
>+- in
>+- ignore (t#connect#response ~callback:setRes);
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- t#show();
>+- GMain.Main.main();
>+- !res
>+-
>+-let summaryBox ~parent ~title ~message ~f =
>+- let t =
>+- GWindow.dialog ~parent ~border_width:6 ~modal:true
>+- ~resizable:false ~focus_on_map:false () in
>+- t#vbox#set_spacing 12;
>+- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>+- ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
>+- ~yalign:0. ~packing:h1#pack ());
>+- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>+- ignore (GMisc.label
>+- ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)
>+- ~selectable:true ~xalign:0. ~yalign:0. ~packing:v1#add ());
>+- let exp = GBin.expander ~spacing:12 ~label:"Show details" ~packing:v1#add () in
>+- let t_text =
>+- new scrolled_text ~editable:false ~shadow_type:`IN
>+- ~width:60 ~height:10 ~packing:exp#add ()
>+- in
>+- f (t_text#text);
>+- t#add_button_stock `OK `OK;
>+- t#set_default_response `OK;
>+- let setRes signal = t#destroy () in
>+- ignore (t#connect#response ~callback:setRes);
>+- ignore (t#connect#destroy ~callback:GMain.Main.quit);
>+- t#show();
>+- GMain.Main.main()
>+-
>+-(**********************************************************************
>+- TOP-LEVEL WINDOW
>+- **********************************************************************)
>+-
>+-let displayWaitMessage () =
>+- make_busy (toplevelWindow ());
>+- Trace.status (Uicommon.contactingServerMsg ())
>+-
>+-(* ------ *)
>+-
>+-type status = NoStatus | Done | Failed
>+-
>+-let createToplevelWindow () =
>+- let toplevelWindow =
>+- GWindow.window ~kind:`TOPLEVEL ~position:`CENTER
>+- ~title:myNameCapitalized ()
>+- in
>+- setToplevelWindow toplevelWindow;
>+- (* There is already a default icon under Windows, and transparent
>+- icons are not supported by all version of Windows *)
>+- if Util.osType <> `Win32 then toplevelWindow#set_icon (Some icon);
>+- let toplevelVBox = GPack.vbox ~packing:toplevelWindow#add () in
>+-
>+- (*******************************************************************
>+- Statistic window
>+- *******************************************************************)
>+-
>+- let (statWin, startStats, stopStats) = statistics () in
>+-
>+- (*******************************************************************
>+- Groups of things that are sensitive to interaction at the same time
>+- *******************************************************************)
>+- let grAction = ref [] in
>+- let grDiff = ref [] in
>+- let grGo = ref [] in
>+- let grRescan = ref [] in
>+- let grDetail = ref [] in
>+- let grAdd gr w = gr := w#misc::!gr in
>+- let grSet gr st = Safelist.iter (fun x -> x#set_sensitive st) !gr in
>+- let grDisactivateAll () =
>+- grSet grAction false;
>+- grSet grDiff false;
>+- grSet grGo false;
>+- grSet grRescan false;
>+- grSet grDetail false
>+- in
>+-
>+- (*********************************************************************
>+- Create the menu bar
>+- *********************************************************************)
>+- let topHBox = GPack.hbox ~packing:(toplevelVBox#pack ~expand:false) () in
>+-
>+- let menuBar =
>+- GMenu.menu_bar ~border_width:0
>+- ~packing:(topHBox#pack ~expand:true) () in
>+- let menus = new gMenuFactory ~accel_modi:[] menuBar in
>+- let accel_group = menus#accel_group in
>+- toplevelWindow#add_accel_group accel_group;
>+- let add_submenu ?(modi=[]) label =
>+- let (menu, item) = menus#add_submenu label in
>+- (new gMenuFactory ~accel_group:(menus#accel_group)
>+- ~accel_path:(menus#accel_path ^ label ^ "/")
>+- ~accel_modi:modi menu,
>+- item)
>+- in
>+- let replace_submenu ?(modi=[]) label item =
>+- let menu = menus#replace_submenu item in
>+- new gMenuFactory ~accel_group:(menus#accel_group)
>+- ~accel_path:(menus#accel_path ^ label ^ "/")
>+- ~accel_modi:modi menu
>+- in
>+-
>+- let profileLabel =
>+- GMisc.label ~text:"" ~packing:(topHBox#pack ~expand:false ~padding:2) () in
>+-
>+- let displayNewProfileLabel () =
>+- let p = match !Prefs.profileName with None -> "" | Some p -> p in
>+- let label = Prefs.read Uicommon.profileLabel in
>+- let s =
>+- match p, label with
>+- "", _ -> ""
>+- | _, "" -> p
>+- | "default", _ -> label
>+- | _ -> Format.sprintf "%s (%s)" p label
>+- in
>+- toplevelWindow#set_title
>+- (if s = "" then myNameCapitalized else
>+- Format.sprintf "%s [%s]" myNameCapitalized s);
>+- let s = if s="" then "No profile" else "Profile: " ^ s in
>+- profileLabel#set_text (transcode s)
>+- in
>+- displayNewProfileLabel ();
>+-
>+- (*********************************************************************
>+- Create the menus
>+- *********************************************************************)
>+- let (fileMenu, _) = add_submenu "_Synchronization" in
>+- let (actionMenu, actionItem) = add_submenu "_Actions" in
>+- let (ignoreMenu, _) = add_submenu ~modi:[`SHIFT] "_Ignore" in
>+- let (sortMenu, _) = add_submenu "S_ort" in
>+- let (helpMenu, _) = add_submenu "_Help" in
>+-
>+- (*********************************************************************
>+- Action bar
>+- *********************************************************************)
>+- let actionBar =
>+- GButton.toolbar ~style:`BOTH
>+- (* 2003-0519 (stse): how to set space size in gtk 2.0? *)
>+- (* Answer from Jacques Garrigue: this can only be done in
>+- the user's.gtkrc, not programmatically *)
>+- ~orientation:`HORIZONTAL (* ~space_size:10 *)
>+- ~packing:(toplevelVBox#pack ~expand:false) () in
>+-
>+- (*********************************************************************
>+- Create the main window
>+- *********************************************************************)
>+- let mainWindowSW =
>+- GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:true)
>+- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
>+- in
>+- let sizeMainWindow () =
>+- let ctx = mainWindowSW#misc#pango_context in
>+- let metrics = ctx#get_metrics () in
>+- let h = GPango.to_pixels (metrics#ascent+metrics#descent) in
>+- toplevelWindow#set_default_height
>+- ((h + 3) * (Prefs.read Uicommon.mainWindowHeight + 1) + 200)
>+- in
>+- let cols = new GTree.column_list in
>+- let c_replica1 = cols#add Gobject.Data.string in
>+- let c_action = cols#add Gobject.Data.gobject in
>+- let c_replica2 = cols#add Gobject.Data.string in
>+- let c_status = cols#add Gobject.Data.gobject_option in
>+- let c_statust = cols#add Gobject.Data.string in
>+- let c_path = cols#add Gobject.Data.string in
>+- (*let c_rowid = cols#add Gobject.Data.uint in*)
>+- (* With current implementation the [list_store] view model and [theState]
>+- array have one-to-one correspondence, so that list_store's tree path index
>+- is the same as theState array index.
>+- This changes when, for example, [tree_store] would be used instead of
>+- list_store, or a separate view-only sorting is implemented without sorting
>+- the backing theState array. In that case, the column [c_rowid] must be
>+- used to store the index of [theState] array in the view model. Tree path
>+- index must not be used directly as [theState] array index and vice versa. *)
>+- let mainWindowModel = GTree.list_store cols in
>+- let mainWindow =
>+- GTree.view ~model:mainWindowModel ~packing:(mainWindowSW#add)
>+- ~headers_clickable:false ~enable_search:false () in
>+- mainWindow#selection#set_mode `MULTIPLE;
>+- ignore (mainWindow#append_column
>+- (GTree.view_column
>+- ~title:(" ")
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_replica1]) ()));
>+- ignore (mainWindow#append_column
>+- (GTree.view_column ~title:" Action "
>+- ~renderer:(GTree.cell_renderer_pixbuf [], ["pixbuf", c_action]) ()));
>+- ignore (mainWindow#append_column
>+- (GTree.view_column
>+- ~title:(" ")
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_replica2]) ()));
>+- let status_view_col = GTree.view_column ~title:" Status "
>+- ~renderer:(GTree.cell_renderer_pixbuf [], ["pixbuf", c_status]) () in
>+- let status_t_rend = GTree.cell_renderer_text [] in
>+- status_view_col#pack ~expand:false ~from:`END status_t_rend;
>+- status_view_col#add_attribute status_t_rend "text" c_statust;
>+- ignore (mainWindow#append_column status_view_col);
>+- ignore (mainWindow#append_column
>+- (GTree.view_column ~title:" Path "
>+- ~renderer:(GTree.cell_renderer_text [], ["text", c_path]) ()));
>+-
>+- let setMainWindowColumnHeaders s =
>+- Array.iteri
>+- (fun i data ->
>+- (mainWindow#get_column i)#set_title data)
>+- [| " " ^ Unicode.protect (String.sub s 0 12) ^ " "; " Action ";
>+- " " ^ Unicode.protect (String.sub s 15 12) ^ " "; " Status ";
>+- " Path" |];
>+- in
>+- sizeMainWindow ();
>+-
>+- (* See above for comment about tree path index and [theState] array index
>+- equivalence. *)
>+- let siOfRow f path =
>+- let row = mainWindowModel#get_iter path in
>+- let i = (GTree.Path.get_indices path).(0) in
>+- (*let i = mainWindowModel#get ~row ~column:c_rowid in*)
>+- f i !theState.(i) row
>+- in
>+- let rowOfSi i = GTree.Path.create [i] in
>+- let currentNumberRows () = mainWindow#selection#count_selected_rows in
>+- let currentRow () =
>+- match currentNumberRows () with
>+- | 1 -> siOfRow (fun i si row -> Some (i, !theState.(i), row))
>+- (List.hd mainWindow#selection#get_selected_rows)
>+- | _ -> None
>+- in
>+- let currentSelectedIter f =
>+- Safelist.iter (fun r -> siOfRow f r)
>+- mainWindow#selection#get_selected_rows
>+- in
>+- let currentSelectedFold f a =
>+- Safelist.fold_left (fun a r -> siOfRow (fun _ si _ -> f a si) r)
>+- a mainWindow#selection#get_selected_rows
>+- in
>+- let currentSelectedExists pred =
>+- Safelist.exists (fun r -> siOfRow (fun _ si _ -> pred si) r)
>+- mainWindow#selection#get_selected_rows
>+- in
>+-
>+- (*********************************************************************
>+- Create the details window
>+- *********************************************************************)
>+-
>+- let showDetCommand () =
>+- let details =
>+- match currentRow () with
>+- None ->
>+- None
>+- | Some (_, si, _) ->
>+- let path = Path.toString si.ri.path1 in
>+- match si.whatHappened with
>+- Some (Util.Failed _, Some det) ->
>+- Some ("Merge execution details for file" ^
>+- transcodeFilename path,
>+- det)
>+- | _ ->
>+- match si.ri.replicas with
>+- Problem err ->
>+- Some ("Errors for file " ^ transcodeFilename path, err)
>+- | Different diff ->
>+- let prefix s l =
>+- Safelist.map (fun err -> Format.sprintf "%s%s\n" s err) l
>+- in
>+- let errors =
>+- Safelist.append
>+- (prefix "[root 1]: " diff.errors1)
>+- (prefix "[root 2]: " diff.errors2)
>+- in
>+- let errors =
>+- match si.whatHappened with
>+- Some (Util.Failed err, _) -> err :: errors
>+- | _ -> errors
>+- in
>+- Some ("Errors for file " ^ transcodeFilename path,
>+- String.concat "\n" errors)
>+- in
>+- match details with
>+- None -> ((* Should not happen *))
>+- | Some (title, details) -> messageBox ~title (transcode details)
>+- in
>+-
>+- let detailsWindowSW =
>+- GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
>+- ~shadow_type:`IN ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
>+- in
>+- let detailsWindow =
>+- GText.view ~editable:false ~packing:detailsWindowSW#add ()
>+- in
>+- let detailsWindowPath = detailsWindow#buffer#create_tag [] in
>+- let detailsWindowInfo =
>+- detailsWindow#buffer#create_tag [`FONT_DESC (Lazy.force fontMonospace)] in
>+- let detailsWindowError =
>+- detailsWindow#buffer#create_tag [`WRAP_MODE `WORD] in
>+- detailsWindow#misc#set_size_chars ~height:3 ~width:112 ();
>+- detailsWindow#misc#set_can_focus false;
>+-
>+- let updateButtons () =
>+- if not !busy then
>+- let actionPossible si =
>+- match si.whatHappened, si.ri.replicas with
>+- None, Different _ -> true
>+- | _ -> false
>+- in
>+- match currentRow () with
>+- None ->
>+- grSet grAction (currentSelectedExists actionPossible);
>+- grSet grDiff false;
>+- grSet grDetail false
>+- | Some (_, si, _) ->
>+- let details =
>+- begin match si.ri.replicas with
>+- Different diff -> diff.errors1 <> [] || diff.errors2 <> []
>+- | Problem _ -> true
>+- end
>+- ||
>+- begin match si.whatHappened with
>+- Some (Util.Failed _, _) -> true
>+- | _ -> false
>+- end
>+- in
>+- grSet grDetail details;
>+- let activateAction = actionPossible si in
>+- let activateDiff =
>+- activateAction &&
>+- match si.ri.replicas with
>+- Different {rc1 = {typ = `FILE}; rc2 = {typ = `FILE}} ->
>+- true
>+- | _ ->
>+- false
>+- in
>+- grSet grAction activateAction;
>+- grSet grDiff activateDiff
>+- in
>+-
>+- let makeRowVisible row =
>+- mainWindow#scroll_to_cell row status_view_col (* just a dummy column *)
>+- in
>+-
>+-(*
>+- let makeFirstUnfinishedVisible pRiInFocus =
>+- let im = Array.length !theState in
>+- let rec find i =
>+- if i >= im then makeRowVisible im else
>+- match pRiInFocus (!theState.(i).ri), !theState.(i).whatHappened with
>+- true, None -> makeRowVisible i
>+- | _ -> find (i+1) in
>+- find 0
>+- in
>+-*)
>+-
>+- let updateDetails () =
>+- begin match currentRow () with
>+- None ->
>+- detailsWindow#buffer#set_text ""
>+- | Some (_, si, _) ->
>+- let (formated, details) =
>+- match si.whatHappened with
>+- | Some(Util.Failed(s), _) ->
>+- (false, s)
>+- | None | Some(Util.Succeeded, _) ->
>+- match si.ri.replicas with
>+- Problem _ ->
>+- (false, Uicommon.details2string si.ri " ")
>+- | Different _ ->
>+- (true, Uicommon.details2string si.ri " ")
>+- in
>+- let path = Path.toString si.ri.path1 in
>+- detailsWindow#buffer#set_text "";
>+- detailsWindow#buffer#insert ~tags:[detailsWindowPath]
>+- (transcodeFilename path);
>+- let len = String.length details in
>+- let details =
>+- if details.[len - 1] = '\n' then String.sub details 0 (len - 1)
>+- else details
>+- in
>+- if details <> "" then
>+- detailsWindow#buffer#insert
>+- ~tags:[if formated then detailsWindowInfo else detailsWindowError]
>+- ("\n" ^ transcode details)
>+- end;
>+- (* Display text *)
>+- updateButtons () in
>+-
>+- (*********************************************************************
>+- Status window
>+- *********************************************************************)
>+-
>+- let statusHBox = GPack.hbox ~packing:(toplevelVBox#pack ~expand:false) () in
>+-
>+- let progressBar =
>+- GRange.progress_bar ~packing:(statusHBox#pack ~expand:false) () in
>+-
>+- progressBar#misc#set_size_chars ~height:1 ~width:28 ();
>+- progressBar#set_show_text true;
>+- progressBar#set_pulse_step 0.02;
>+- let progressBarPulse = ref false in
>+-
>+- let statusWindow =
>+- GMisc.statusbar ~packing:(statusHBox#pack ~expand:true) () in
>+- let statusContext = statusWindow#new_context ~name:"status" in
>+- ignore (statusContext#push "");
>+-
>+- let displayStatus m =
>+- statusContext#pop ();
>+- if !progressBarPulse then progressBar#pulse ();
>+- ignore (statusContext#push (transcode m));
>+- (* Force message to be displayed immediately *)
>+- gtk_sync false
>+- in
>+-
>+- let formatStatus major minor = (Util.padto 30 (major ^ " ")) ^ minor in
>+-
>+- (* Tell the Trace module about the status printer *)
>+- Trace.messageDisplayer := displayStatus;
>+- Trace.statusFormatter := formatStatus;
>+- Trace.sendLogMsgsToStderr := false;
>+-
>+- (*********************************************************************
>+- Functions used to print in the main window
>+- *********************************************************************)
>+- let delayUpdates = ref false in
>+-
>+- let select row scroll =
>+- delayUpdates := true;
>+- mainWindow#selection#unselect_all ();
>+- mainWindow#selection#select_path row;
>+- mainWindow#set_cursor row status_view_col (* just a dummy column *);
>+- delayUpdates := false;
>+- if scroll then makeRowVisible row;
>+- updateDetails ()
>+- in
>+- let selectI i scroll = select (rowOfSi i) scroll in
>+-
>+- ignore (mainWindow#selection#connect#changed ~callback:
>+- (fun () -> if not !delayUpdates then updateDetails ()));
>+-
>+- let nextInteresting () =
>+- let l = Array.length !theState in
>+- let start = match currentRow () with Some (i, _, _) -> i + 1 | None -> 0 in
>+- let rec loop i =
>+- if i < l then
>+- match !theState.(i).ri.replicas with
>+- Different {direction = dir}
>+- when not (Prefs.read Uicommon.auto) || isConflict dir ->
>+- selectI i true
>+- | _ ->
>+- loop (i + 1) in
>+- loop start in
>+- let selectSomethingIfPossible () =
>+- if currentNumberRows () = 0 then nextInteresting () in
>+-
>+- let columnsOf si =
>+- let oldPath = Path.empty in
>+- let status =
>+- match si.ri.replicas with
>+- Different {direction = Conflict _} | Problem _ ->
>+- NoStatus
>+- | _ ->
>+- match si.whatHappened with
>+- None -> NoStatus
>+- | Some (Util.Succeeded, _) -> Done
>+- | Some (Util.Failed _, _) -> Failed
>+- in
>+- let (r1, action, r2, path) =
>+- Uicommon.reconItem2stringList oldPath si.ri in
>+- (r1, action, r2, status, path)
>+- in
>+-
>+- let greenPixel = "00dd00" in
>+- let redPixel = "ff2040" in
>+- let lightbluePixel = "8888FF" in
>+- let orangePixel = "ff9303" in
>+-(*
>+- let yellowPixel = "999900" in
>+- let blackPixel = "000000" in
>+-*)
>+- let buildPixmap p =
>+- GdkPixbuf.from_xpm_data p in
>+- let buildPixmaps f c1 =
>+- (buildPixmap (f c1), buildPixmap (f lightbluePixel)) in
>+-
>+- let doneIcon = buildPixmap Pixmaps.success in
>+- let failedIcon = buildPixmap Pixmaps.failure in
>+- let rightArrow = buildPixmaps Pixmaps.copyAB greenPixel in
>+- let leftArrow = buildPixmaps Pixmaps.copyBA greenPixel in
>+- let orangeRightArrow = buildPixmaps Pixmaps.copyAB orangePixel in
>+- let orangeLeftArrow = buildPixmaps Pixmaps.copyBA orangePixel in
>+- let ignoreAct = buildPixmaps Pixmaps.ignore redPixel in
>+- let failedIcons = (failedIcon, failedIcon) in
>+- let mergeLogo = buildPixmaps Pixmaps.mergeLogo greenPixel in
>+-(*
>+- let rightArrowBlack = buildPixmap (Pixmaps.copyAB blackPixel) in
>+- let leftArrowBlack = buildPixmap (Pixmaps.copyBA blackPixel) in
>+- let mergeLogoBlack = buildPixmap (Pixmaps.mergeLogo blackPixel) in
>+-*)
>+-
>+- let getArrow j action =
>+- let changedFromDefault = match !theState.(j).ri.replicas with
>+- Different diff -> diff.direction <> diff.default_direction
>+- | _ -> false in
>+- let sel pixmaps =
>+- if changedFromDefault then snd pixmaps else fst pixmaps in
>+- let pixmaps =
>+- match action with
>+- Uicommon.AError -> failedIcons
>+- | Uicommon.ASkip _ -> ignoreAct
>+- | Uicommon.ALtoR false -> rightArrow
>+- | Uicommon.ALtoR true -> orangeRightArrow
>+- | Uicommon.ARtoL false -> leftArrow
>+- | Uicommon.ARtoL true -> orangeLeftArrow
>+- | Uicommon.AMerge -> mergeLogo
>+- in
>+- sel pixmaps
>+- in
>+-
>+-
>+- let getStatusIcon = function
>+- | Failed -> Some failedIcon
>+- | Done -> Some doneIcon
>+- | NoStatus -> None in
>+-
>+- let displayRowAction row i action =
>+- mainWindowModel#set ~row ~column:c_action (getArrow i action) in
>+- let displayRowStatus row status =
>+- mainWindowModel#set ~row ~column:c_status (getStatusIcon status);
>+- if status <> NoStatus then
>+- mainWindowModel#set ~row ~column:c_statust "" in
>+- let displayRowPath row path =
>+- mainWindowModel#set ~row ~column:c_path (transcodeFilename path) in
>+- let displayRow row i r1 r2 action status path =
>+- mainWindowModel#set ~row ~column:c_replica1 r1;
>+- mainWindowModel#set ~row ~column:c_replica2 r2;
>+- displayRowAction row i action;
>+- displayRowStatus row status;
>+- displayRowPath row path;
>+- (*mainWindowModel#set ~row ~column:c_rowid i;*)
>+- in
>+-
>+- let displayMain() =
>+- (* The call to mainWindow#clear below side-effect current,
>+- so we save the current value before we clear out the main window and
>+- rebuild it. *)
>+- let savedCurrent = mainWindow#selection#get_selected_rows in
>+- mainWindow#set_model None;
>+- mainWindowModel#clear ();
>+- let tot = Array.length !theState - 1 in
>+- let totf = float_of_int (tot + 1) in
>+- progressBar#set_text (Printf.sprintf "Displaying %i items..." (tot + 1));
>+- for i = 0 to tot do
>+- if i mod 1024 = 0 then begin
>+- progressBar#set_fraction (max 0. (min 1. ((float_of_int i) /. totf)));
>+- gtk_sync false
>+- end;
>+-
>+- let (r1, action, r2, status, path) = columnsOf !theState.(i) in
>+-
>+- let row = mainWindowModel#append () in
>+- displayRow row i r1 r2 action status path;
>+- done;
>+- mainWindow#set_model (Some mainWindowModel#coerce);
>+- match savedCurrent with
>+- | [] -> selectSomethingIfPossible ()
>+- | [x] -> select x true
>+- | _ -> Safelist.iter (fun p -> mainWindow#selection#select_path p) savedCurrent;
>+-
>+- progressBar#set_text ""; progressBar#set_fraction 0.;
>+- updateDetails (); (* Do we need this line? *)
>+- in
>+-
>+- let redisplay i si iter =
>+- let (_, action, _, status, path) = columnsOf si in
>+- displayRowAction iter i action;
>+- displayRowStatus iter status;
>+- if status = Failed then displayRowPath iter (path ^
>+- " [failed: click on this line for details]");
>+- in
>+-
>+- let fastRedisplay i =
>+- let si = !theState.(i) in
>+- let iter = mainWindowModel#get_iter (rowOfSi i) in
>+- let (_, action, _, status, path) = columnsOf si in
>+- displayRowStatus iter status;
>+- if status = Failed then begin
>+- displayRowPath iter (path ^
>+- " [failed: click on this line for details]");
>+- match currentRow () with
>+- | Some (_, csi, _) when csi = si -> updateDetails ()
>+- | Some _ | None -> ()
>+- end
>+- in
>+-
>+- let updateRowStatus i newstatus =
>+- let row = mainWindowModel#get_iter (rowOfSi i) in
>+- let oldstatus = mainWindowModel#get ~row ~column:c_statust in
>+- if oldstatus <> newstatus then mainWindowModel#set ~row ~column:c_statust newstatus
>+- in
>+-
>+- let totalBytesToTransfer = ref Uutil.Filesize.zero in
>+- let totalBytesTransferred = ref Uutil.Filesize.zero in
>+-
>+- let t0 = ref 0. in
>+- let t1 = ref 0. in
>+- let lastFrac = ref 0. in
>+- let oldWritten = ref 0. in
>+- let writeRate = ref 0. in
>+- let displayGlobalProgress v =
>+- if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
>+- lastFrac := v;
>+- progressBar#set_fraction (max 0. (min 1. (v /. 100.)))
>+- end;
>+- if v < 0.001 then
>+- progressBar#set_text " "
>+- else begin
>+- let t = Unix.gettimeofday () in
>+- let delta = t -. !t1 in
>+- if delta >= 0.5 then begin
>+- t1 := t;
>+- let remTime =
>+- if v >= 100. then "00:00 remaining" else
>+- let t = truncate ((!t1 -. !t0) *. (100. -. v) /. v +. 0.5) in
>+- Format.sprintf "%02d:%02d remaining" (t / 60) (t mod 60)
>+- in
>+- let written = !clientWritten +. !serverWritten in
>+- let b = 0.64 ** delta in
>+- writeRate :=
>+- b *. !writeRate +.
>+- (1. -. b) *. (written -. !oldWritten) /. delta;
>+- oldWritten := written;
>+- let rate = !writeRate (*!emitRate2 +. !receiveRate2*) in
>+- let txt =
>+- if rate > 99. then
>+- Format.sprintf "%s (%s)" remTime (rate2str rate)
>+- else
>+- remTime
>+- in
>+- progressBar#set_text txt
>+- end
>+- end
>+- in
>+-
>+- let showGlobalProgress b =
>+- (* Concatenate the new message *)
>+- totalBytesTransferred := Uutil.Filesize.add !totalBytesTransferred b;
>+- let v =
>+- (Uutil.Filesize.percentageOfTotalSize
>+- !totalBytesTransferred !totalBytesToTransfer)
>+- in
>+- displayGlobalProgress v
>+- in
>+-
>+- let root1IsLocal = ref true in
>+- let root2IsLocal = ref true in
>+-
>+- let initGlobalProgress b =
>+- let (root1,root2) = Globals.roots () in
>+- root1IsLocal := fst root1 = Local;
>+- root2IsLocal := fst root2 = Local;
>+- totalBytesToTransfer := b;
>+- totalBytesTransferred := Uutil.Filesize.zero;
>+- t0 := Unix.gettimeofday (); t1 := !t0;
>+- writeRate := 0.; oldWritten := !clientWritten +. !serverWritten;
>+- displayGlobalProgress 0.
>+- in
>+-
>+- let showProgress i bytes dbg =
>+- let i = Uutil.File.toLine i in
>+- let item = !theState.(i) in
>+- item.bytesTransferred <- Uutil.Filesize.add item.bytesTransferred bytes;
>+- let b = item.bytesTransferred in
>+- let len = item.bytesToTransfer in
>+- let newstatus =
>+- if b = Uutil.Filesize.zero || len = Uutil.Filesize.zero then "start "
>+- else if len = Uutil.Filesize.zero then
>+- Printf.sprintf "%5s " (Uutil.Filesize.toString b)
>+- else Util.percent2string (Uutil.Filesize.percentageOfTotalSize b len) in
>+- let dbg = if Trace.enabled "progress" then dbg ^ "/" else "" in
>+- let newstatus = dbg ^ newstatus in
>+- updateRowStatus i newstatus;
>+- showGlobalProgress bytes;
>+- gtk_sync false;
>+- begin match item.ri.replicas with
>+- Different diff ->
>+- begin match diff.direction with
>+- Replica1ToReplica2 ->
>+- if !root2IsLocal then
>+- clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes
>+- else
>+- serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes
>+- | Replica2ToReplica1 ->
>+- if !root1IsLocal then
>+- clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes
>+- else
>+- serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes
>+- | Conflict _ | Merge ->
>+- (* Diff / merge *)
>+- clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes
>+- end
>+- | _ ->
>+- assert false
>+- end
>+- in
>+-
>+- (* Install showProgress so that we get called back by low-level
>+- file transfer stuff *)
>+- Uutil.setProgressPrinter showProgress;
>+-
>+- (* Apply new ignore patterns to the current state, expecting that the
>+- number of reconitems will grow smaller. Adjust the display, being
>+- careful to keep the cursor as near as possible to its position
>+- before the new ignore patterns take effect. *)
>+- let ignoreAndRedisplay () =
>+- let lst = Array.to_list !theState in
>+- (* FIX: we should actually test whether any prefix is now ignored *)
>+- let keep sI = not (Globals.shouldIgnore sI.ri.path1) in
>+- theState := Array.of_list (Safelist.filter keep lst);
>+- displayMain() in
>+-
>+- let sortAndRedisplay () =
>+- let compareRIs = Sortri.compareReconItems() in
>+- Array.stable_sort (fun si1 si2 -> compareRIs si1.ri si2.ri) !theState;
>+- displayMain() in
>+-
>+- (******************************************************************
>+- Main detect-updates-and-reconcile logic
>+- ******************************************************************)
>+-
>+- let commitUpdates () =
>+- Trace.status "Updating synchronizer state";
>+- let t = Trace.startTimer "Updating synchronizer state" in
>+- gtk_sync true;
>+- Update.commitUpdates();
>+- Trace.showTimer t
>+- in
>+-
>+- let clearMainWindow () =
>+- grDisactivateAll ();
>+- make_busy toplevelWindow;
>+- mainWindowModel#clear ();
>+- detailsWindow#buffer#set_text ""
>+- in
>+-
>+- let detectUpdatesAndReconcile () =
>+- clearMainWindow ();
>+- startStats ();
>+- progressBarPulse := true;
>+- sync_action := Some (fun () -> progressBar#pulse ());
>+- let findUpdates () =
>+- let t = Trace.startTimer "Checking for updates" in
>+- Trace.status "Looking for changes";
>+- let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in
>+- Trace.showTimer t;
>+- updates in
>+- let reconcile updates =
>+- let t = Trace.startTimer "Reconciling" in
>+- let reconRes = Recon.reconcileAll ~allowPartial:true updates in
>+- Trace.showTimer t;
>+- reconRes in
>+- let (reconItemList, thereAreEqualUpdates, dangerousPaths) =
>+- reconcile (findUpdates ()) in
>+- if not !Update.foundArchives then commitUpdates ();
>+- if reconItemList = [] then begin
>+- if !Update.foundArchives then commitUpdates ();
>+- if thereAreEqualUpdates then
>+- Trace.status
>+- "Replicas have been changed only in identical ways since last sync"
>+- else
>+- Trace.status "Everything is up to date"
>+- end else
>+- Trace.status "Check and/or adjust selected actions; then press Go";
>+- theState :=
>+- Array.of_list
>+- (Safelist.map
>+- (fun ri -> { ri = ri;
>+- bytesTransferred = Uutil.Filesize.zero;
>+- bytesToTransfer = Uutil.Filesize.zero;
>+- whatHappened = None })
>+- reconItemList);
>+- unsynchronizedPaths :=
>+- Some (Safelist.map (fun ri -> ri.path1) reconItemList, []);
>+- progressBarPulse := false; sync_action := None; displayGlobalProgress 0.;
>+- displayMain();
>+- progressBarPulse := false; sync_action := None; displayGlobalProgress 0.;
>+- stopStats ();
>+- grSet grGo (Array.length !theState > 0);
>+- grSet grRescan true;
>+- make_interactive toplevelWindow;
>+- if Prefs.read Globals.confirmBigDeletes then begin
>+- if dangerousPaths <> [] then begin
>+- Prefs.set Globals.batch false;
>+- Util.warn (Uicommon.dangerousPathMsg dangerousPaths)
>+- end;
>+- end;
>+- in
>+-
>+- (*********************************************************************
>+- Help menu
>+- *********************************************************************)
>+- let addDocSection (shortname, (name, docstr)) =
>+- if shortname = "about" then
>+- ignore (helpMenu#add_image_item
>+- ~stock:`ABOUT ~callback:(fun () -> documentation shortname)
>+- name)
>+- else if shortname <> "" && name <> "" then
>+- ignore (helpMenu#add_item
>+- ~callback:(fun () -> documentation shortname)
>+- name) in
>+- Safelist.iter addDocSection Strings.docs;
>+-
>+- (*********************************************************************
>+- Ignore menu
>+- *********************************************************************)
>+- let addRegExpByPath pathfunc =
>+- Util.StringSet.iter (fun pat -> Uicommon.addIgnorePattern pat)
>+- (currentSelectedFold
>+- (fun s si -> Util.StringSet.add (pathfunc si.ri.path1) s)
>+- Util.StringSet.empty);
>+- ignoreAndRedisplay ()
>+- in
>+- grAdd grAction
>+- (ignoreMenu#add_item ~key:GdkKeysyms._i
>+- ~callback:(fun () -> getLock (fun () ->
>+- addRegExpByPath Uicommon.ignorePath))
>+- "Permanently Ignore This _Path");
>+- grAdd grAction
>+- (ignoreMenu#add_item ~key:GdkKeysyms._E
>+- ~callback:(fun () -> getLock (fun () ->
>+- addRegExpByPath Uicommon.ignoreExt))
>+- "Permanently Ignore Files with this _Extension");
>+- grAdd grAction
>+- (ignoreMenu#add_item ~key:GdkKeysyms._N
>+- ~callback:(fun () -> getLock (fun () ->
>+- addRegExpByPath Uicommon.ignoreName))
>+- "Permanently Ignore Files with this _Name (in any Dir)");
>+-
>+- (*
>+- grAdd grRescan
>+- (ignoreMenu#add_item ~callback:
>+- (fun () -> getLock ignoreDialog) "Edit ignore patterns");
>+- *)
>+-
>+- (*********************************************************************
>+- Sort menu
>+- *********************************************************************)
>+- grAdd grRescan
>+- (sortMenu#add_item
>+- ~callback:(fun () -> getLock (fun () ->
>+- Sortri.sortByName();
>+- sortAndRedisplay()))
>+- "Sort by _Name");
>+- grAdd grRescan
>+- (sortMenu#add_item
>+- ~callback:(fun () -> getLock (fun () ->
>+- Sortri.sortBySize();
>+- sortAndRedisplay()))
>+- "Sort by _Size");
>+- grAdd grRescan
>+- (sortMenu#add_item
>+- ~callback:(fun () -> getLock (fun () ->
>+- Sortri.sortNewFirst();
>+- sortAndRedisplay()))
>+- "Sort Ne_w Entries First (toggle)");
>+- grAdd grRescan
>+- (sortMenu#add_item
>+- ~callback:(fun () -> getLock (fun () ->
>+- Sortri.restoreDefaultSettings();
>+- sortAndRedisplay()))
>+- "_Default Ordering");
>+-
>+- (*********************************************************************
>+- Main function : synchronize
>+- *********************************************************************)
>+- let synchronize () =
>+- if Array.length !theState = 0 then
>+- Trace.status "Nothing to synchronize"
>+- else begin
>+- grDisactivateAll ();
>+- make_busy toplevelWindow;
>+-
>+- Trace.status "Propagating changes";
>+- Transport.logStart ();
>+- let totalLength =
>+- Array.fold_left
>+- (fun l si ->
>+- si.bytesTransferred <- Uutil.Filesize.zero;
>+- let len =
>+- if si.whatHappened = None then Common.riLength si.ri else
>+- Uutil.Filesize.zero
>+- in
>+- si.bytesToTransfer <- len;
>+- Uutil.Filesize.add l len)
>+- Uutil.Filesize.zero !theState in
>+- initGlobalProgress totalLength;
>+- let t = Trace.startTimer "Propagating changes" in
>+- let im = Array.length !theState in
>+- let rec loop i actions pRiThisRound =
>+- if i < im then begin
>+- let theSI = !theState.(i) in
>+- let textDetailed = ref None in
>+- let action =
>+- match theSI.whatHappened with
>+- None ->
>+- if not (pRiThisRound theSI.ri) then
>+- return ()
>+- else
>+- catch (fun () ->
>+- Transport.transportItem
>+- theSI.ri (Uutil.File.ofLine i)
>+- (fun title text ->
>+- textDetailed := (Some text);
>+- if Prefs.read Uicommon.confirmmerge then
>+- twoBoxAdvanced
>+- ~parent:toplevelWindow
>+- ~title:title
>+- ~message:("Do you want to commit the changes to"
>+- ^ " the replicas ?")
>+- ~longtext:text
>+- ~advLabel:"View details..."
>+- ~astock:`YES
>+- ~bstock:`NO
>+- else
>+- true)
>+- >>= (fun () ->
>+- return Util.Succeeded))
>+- (fun e ->
>+- match e with
>+- Util.Transient s ->
>+- return (Util.Failed s)
>+- | _ ->
>+- fail e)
>+- >>= (fun res ->
>+- let rem =
>+- Uutil.Filesize.sub
>+- theSI.bytesToTransfer theSI.bytesTransferred
>+- in
>+- if rem <> Uutil.Filesize.zero then
>+- showProgress (Uutil.File.ofLine i) rem "done";
>+- theSI.whatHappened <- Some (res, !textDetailed);
>+- fastRedisplay i;
>+-(* JV (7/09): It does not seem that useful to me to scroll the display
>+- to make the first unfinished item visible. The scrolling is way
>+- too fast, and it makes it impossible to browse the list. *)
>+-(*
>+- sync_action :=
>+- Some
>+- (fun () ->
>+- makeFirstUnfinishedVisible pRiThisRound;
>+- sync_action := None);
>+-*)
>+- gtk_sync false;
>+- return ())
>+- | Some _ ->
>+- return () (* Already processed this one (e.g. merged it) *)
>+- in
>+- loop (i + 1) (action :: actions) pRiThisRound
>+- end else
>+- actions
>+- in
>+- startStats ();
>+- Lwt_unix.run
>+- (let actions = loop 0 [] (fun ri -> not (Common.isDeletion ri)) in
>+- Lwt_util.join actions);
>+- Lwt_unix.run
>+- (let actions = loop 0 [] Common.isDeletion in
>+- Lwt_util.join actions);
>+- Transport.logFinish ();
>+- Trace.showTimer t;
>+- commitUpdates ();
>+- stopStats ();
>+-
>+- let failureList =
>+- Array.fold_right
>+- (fun si l ->
>+- match si.whatHappened with
>+- Some (Util.Failed err, _) ->
>+- (si, [err], "transport failure") :: l
>+- | _ ->
>+- l)
>+- !theState []
>+- in
>+- let failureCount = List.length failureList in
>+- let failures =
>+- if failureCount = 0 then [] else
>+- [Printf.sprintf "%d failure%s"
>+- failureCount (if failureCount = 1 then "" else "s")]
>+- in
>+- let partialList =
>+- Array.fold_right
>+- (fun si l ->
>+- match si.whatHappened with
>+- Some (Util.Succeeded, _)
>+- when partiallyProblematic si.ri &&
>+- not (problematic si.ri) ->
>+- let errs =
>+- match si.ri.replicas with
>+- Different diff -> diff.errors1 @ diff.errors2
>+- | _ -> assert false
>+- in
>+- (si, errs,
>+- "partial transfer (errors during update detection)") :: l
>+- | _ ->
>+- l)
>+- !theState []
>+- in
>+- let partialCount = List.length partialList in
>+- let partials =
>+- if partialCount = 0 then [] else
>+- [Printf.sprintf "%d partially transferred" partialCount]
>+- in
>+- let skippedList =
>+- Array.fold_right
>+- (fun si l ->
>+- match si.ri.replicas with
>+- Problem err ->
>+- (si, [err], "error during update detection") :: l
>+- | Different diff when isConflict diff.direction ->
>+- (si, [],
>+- if isConflict diff.default_direction then
>+- "conflict"
>+- else "skipped") :: l
>+- | _ ->
>+- l)
>+- !theState []
>+- in
>+- let skippedCount = List.length skippedList in
>+- let skipped =
>+- if skippedCount = 0 then [] else
>+- [Printf.sprintf "%d skipped" skippedCount]
>+- in
>+- unsynchronizedPaths :=
>+- Some (Safelist.map (fun (si, _, _) -> si.ri.path1)
>+- (failureList @ partialList @ skippedList),
>+- []);
>+- Trace.status
>+- (Printf.sprintf "Synchronization complete %s"
>+- (String.concat ", " (failures @ partials @ skipped)));
>+- displayGlobalProgress 0.;
>+-
>+- grSet grRescan true;
>+- make_interactive toplevelWindow;
>+-
>+- let totalCount = failureCount + partialCount + skippedCount in
>+- if totalCount > 0 then begin
>+- let format n item sing plur =
>+- match n with
>+- 0 -> []
>+- | 1 -> [Format.sprintf "one %s%s" item sing]
>+- | n -> [Format.sprintf "%d %s%s" n item plur]
>+- in
>+- let infos =
>+- format failureCount "failure" "" "s" @
>+- format partialCount "partially transferred director" "y" "ies" @
>+- format skippedCount "skipped item" "" "s"
>+- in
>+- let message =
>+- (if failureCount = 0 then "The synchronization was successful.\n\n"
>+- else "") ^
>+- "The replicas are not fully synchronized.\n" ^
>+- (if totalCount < 2 then "There was" else "There were") ^
>+- begin match infos with
>+- [] -> assert false
>+- | [x] -> " " ^ x
>+- | l -> ":\n - " ^ String.concat ";\n - " l
>+- end ^
>+- "."
>+- in
>+- summaryBox ~parent:toplevelWindow
>+- ~title:"Synchronization summary" ~message ~f:
>+- (fun t ->
>+- let bullet = "\xe2\x80\xa2 " in
>+- let layout = Pango.Layout.create t#misc#pango_context#as_context in
>+- Pango.Layout.set_text layout bullet;
>+- let (n, _) = Pango.Layout.get_pixel_size layout in
>+- let path =
>+- t#buffer#create_tag [`FONT_DESC (Lazy.force fontBold)] in
>+- let description =
>+- t#buffer#create_tag [`FONT_DESC (Lazy.force fontItalic)] in
>+- let errorFirstLine =
>+- t#buffer#create_tag [`LEFT_MARGIN (n); `INDENT (- n)] in
>+- let errorNextLines =
>+- t#buffer#create_tag [`LEFT_MARGIN (2 * n)] in
>+- List.iter
>+- (fun (si, errs, desc) ->
>+- t#buffer#insert ~tags:[path]
>+- (transcodeFilename (Path.toString si.ri.path1));
>+- t#buffer#insert ~tags:[description]
>+- (" \xe2\x80\x94 " ^ desc ^ "\n");
>+- List.iter
>+- (fun err ->
>+- let errl =
>+- Str.split (Str.regexp_string "\n") (transcode err) in
>+- match errl with
>+- [] ->
>+- ()
>+- | f :: rem ->
>+- t#buffer#insert ~tags:[errorFirstLine]
>+- (bullet ^ f ^ "\n");
>+- List.iter
>+- (fun n ->
>+- t#buffer#insert ~tags:[errorNextLines]
>+- (n ^ "\n"))
>+- rem)
>+- errs)
>+- (failureList @ partialList @ skippedList))
>+- end
>+-
>+- end in
>+-
>+- (*********************************************************************
>+- Buttons for -->, M, <--, Skip
>+- *********************************************************************)
>+- let doActionOnRow f i theSI iter =
>+- begin match theSI.whatHappened, theSI.ri.replicas with
>+- None, Different diff ->
>+- f theSI.ri diff;
>+- redisplay i theSI iter
>+- | _ ->
>+- ()
>+- end
>+- in
>+- let doAction f =
>+- match currentRow () with
>+- Some (i, si, iter) ->
>+- doActionOnRow f i si iter;
>+- nextInteresting ()
>+- | None ->
>+- currentSelectedIter (fun i si iter -> doActionOnRow f i si iter);
>+- updateDetails ()
>+- in
>+- let leftAction _ =
>+- doAction (fun _ diff -> diff.direction <- Replica2ToReplica1) in
>+- let rightAction _ =
>+- doAction (fun _ diff -> diff.direction <- Replica1ToReplica2) in
>+- let questionAction _ = doAction (fun _ diff -> diff.direction <- Conflict "") in
>+- let mergeAction _ = doAction (fun _ diff -> diff.direction <- Merge) in
>+-
>+- let insert_button (toolbar : #GButton.toolbar) ~stock ~text ~tooltip ~callback () =
>+- let b = GButton.tool_button ~stock ~label:text ~packing:toolbar#insert () in
>+- ignore (b#connect#clicked ~callback);
>+- b#misc#set_tooltip_text tooltip;
>+- b
>+- in
>+-
>+-(* actionBar#insert_space ();*)
>+- grAdd grAction
>+- (insert_button actionBar
>+- ~stock:`GO_FORWARD
>+- ~text:"Left to Right"
>+- ~tooltip:"Propagate selected items\n\
>+- from the left replica to the right one"
>+- ~callback:rightAction ());
>+-(* actionBar#insert_space ();*)
>+- grAdd grAction
>+- (insert_button actionBar ~text:"Skip"
>+- ~stock:`NO
>+- ~tooltip:"Skip selected items"
>+- ~callback:questionAction ());
>+-(* actionBar#insert_space ();*)
>+- grAdd grAction
>+- (insert_button actionBar
>+- ~stock:`GO_BACK
>+- ~text:"Right to Left"
>+- ~tooltip:"Propagate selected items\n\
>+- from the right replica to the left one"
>+- ~callback:leftAction ());
>+-(* actionBar#insert_space ();*)
>+- grAdd grAction
>+- (insert_button actionBar
>+- ~stock:`ADD
>+- ~text:"Merge"
>+- ~tooltip:"Merge selected files"
>+- ~callback:mergeAction ());
>+-
>+- (*********************************************************************
>+- Diff / merge buttons
>+- *********************************************************************)
>+- let diffCmd () =
>+- match currentRow () with
>+- Some (i, item, _) ->
>+- getLock (fun () ->
>+- let len =
>+- match item.ri.replicas with
>+- Problem _ ->
>+- Uutil.Filesize.zero
>+- | Different diff ->
>+- snd (if !root1IsLocal then diff.rc2 else diff.rc1).size
>+- in
>+- item.bytesTransferred <- Uutil.Filesize.zero;
>+- item.bytesToTransfer <- len;
>+- initGlobalProgress len;
>+- startStats ();
>+- Uicommon.showDiffs item.ri
>+- (fun title text ->
>+- messageBox ~title:(transcode title) (transcode text))
>+- Trace.status (Uutil.File.ofLine i);
>+- stopStats ();
>+- displayGlobalProgress 0.;
>+- fastRedisplay i)
>+- | None ->
>+- () in
>+-
>+- actionBar#insert (GButton.separator_tool_item ());
>+- grAdd grDiff (insert_button actionBar ~text:"Diff"
>+- ~stock:`DIALOG_INFO
>+- ~tooltip:"Compare the two files at each replica"
>+- ~callback:diffCmd ());
>+-
>+- (*********************************************************************
>+- Detail button
>+- *********************************************************************)
>+-(* actionBar#insert_space ();*)
>+- grAdd grDetail (insert_button actionBar ~text:"Details"
>+- ~stock:`INFO
>+- ~tooltip:"Show detailed information about\n\
>+- an item, when available"
>+- ~callback:showDetCommand ());
>+-
>+- (*********************************************************************
>+- Quit button
>+- *********************************************************************)
>+-(* actionBar#insert_space ();
>+- ignore (actionBar#insert_button ~text:"Quit"
>+- ~icon:((GMisc.image ~stock:`QUIT ())#coerce)
>+- ~tooltip:"Exit Unison"
>+- ~callback:safeExit ());
>+-*)
>+-
>+- (*********************************************************************
>+- go button
>+- *********************************************************************)
>+- actionBar#insert (GButton.separator_tool_item ());
>+- grAdd grGo
>+- (insert_button actionBar ~text:"Go"
>+- (* tooltip:"Go with displayed actions" *)
>+- ~stock:`EXECUTE
>+- ~tooltip:"Perform the synchronization"
>+- ~callback:(fun () ->
>+- getLock synchronize) ());
>+-
>+- (* Does not quite work: too slow, and Files.copy must be modifed to
>+- support an interruption without error. *)
>+- (*
>+- ignore (actionBar#insert_button ~text:"Stop"
>+- ~icon:((GMisc.image ~stock:`STOP ())#coerce)
>+- ~tooltip:"Exit Unison"
>+- ~callback:Abort.all ());
>+- *)
>+-
>+- (*********************************************************************
>+- Rescan button
>+- *********************************************************************)
>+- let updateFromProfile = ref (fun () -> ()) in
>+-
>+- let prepDebug () =
>+- if Sys.os_type = "Win32" then
>+- (* As a side-effect, this allocates a console if the process doesn't
>+- have one already. This call is here only for the side-effect,
>+- because debugging output is produced on stderr and the GUI will
>+- crash if there is no stderr. *)
>+- try ignore (System.terminalStateFunctions ())
>+- with Unix.Unix_error _ -> ()
>+- in
>+-
>+- let loadProfile p reload =
>+- debug (fun()-> Util.msg "Loading profile %s..." p);
>+- Trace.status "Loading profile";
>+- unsynchronizedPaths := None;
>+- Uicommon.initPrefs ~profileName:p
>+- ~displayWaitMessage:(fun () -> if not reload then displayWaitMessage ())
>+- ~getFirstRoot ~getSecondRoot ~prepDebug ~termInteract ();
>+- !updateFromProfile ()
>+- in
>+-
>+- let reloadProfile () =
>+- let n =
>+- match !Prefs.profileName with
>+- None -> assert false
>+- | Some n -> n
>+- in
>+- clearMainWindow ();
>+- if not (Prefs.profileUnchanged ()) then loadProfile n true
>+- else Uicommon.refreshConnection ~displayWaitMessage ~termInteract
>+- in
>+-
>+- let detectCmd () =
>+- getLock detectUpdatesAndReconcile;
>+- updateDetails ();
>+- if Prefs.read Globals.batch then begin
>+- Prefs.set Globals.batch false; synchronize()
>+- end
>+- in
>+-(* actionBar#insert_space ();*)
>+- grAdd grRescan
>+- (insert_button actionBar ~text:"Rescan"
>+- ~stock:`REFRESH
>+- ~tooltip:"Check for updates"
>+- ~callback: (fun () -> reloadProfile(); detectCmd()) ());
>+-
>+- (*********************************************************************
>+- Profile change button
>+- *********************************************************************)
>+- actionBar#insert (GButton.separator_tool_item ());
>+- let profileChange _ =
>+- match getProfile false with
>+- None -> ()
>+- | Some p -> clearMainWindow (); loadProfile p false; detectCmd ()
>+- in
>+- grAdd grRescan (insert_button actionBar ~text:"Change Profile"
>+- ~stock:`OPEN
>+- ~tooltip:"Select a different profile"
>+- ~callback:profileChange ());
>+-
>+- (*********************************************************************
>+- Keyboard commands
>+- *********************************************************************)
>+- ignore
>+- (mainWindow#event#connect#key_press ~callback:
>+- begin fun ev ->
>+- let key = GdkEvent.Key.keyval ev in
>+- if key = GdkKeysyms._Left then begin
>+- leftAction (); GtkSignal.stop_emit (); true
>+- end else if key = GdkKeysyms._Right then begin
>+- rightAction (); GtkSignal.stop_emit (); true
>+- end else
>+- false
>+- end);
>+-
>+- (*********************************************************************
>+- Action menu
>+- *********************************************************************)
>+- let buildActionMenu init =
>+- let withDelayedUpdates f x =
>+- delayUpdates := true;
>+- f x;
>+- delayUpdates := false;
>+- updateDetails () in
>+- let actionMenu = replace_submenu "_Actions" actionItem in
>+- grAdd grRescan
>+- (actionMenu#add_image_item
>+- ~callback:(fun _ -> withDelayedUpdates mainWindow#selection#select_all ())
>+- ~image:((GMisc.image ~stock:`SELECT_ALL ~icon_size:`MENU ())#coerce)
>+- ~modi:[`CONTROL] ~key:GdkKeysyms._A
>+- "Select _All");
>+- grAdd grRescan
>+- (actionMenu#add_item
>+- ~callback:(fun _ -> withDelayedUpdates mainWindow#selection#unselect_all ())
>+- ~modi:[`SHIFT; `CONTROL] ~key:GdkKeysyms._A
>+- "_Deselect All");
>+-
>+- ignore (actionMenu#add_separator ());
>+-
>+- let (loc1, loc2) =
>+- if init then ("", "") else
>+- let (root1,root2) = Globals.roots () in
>+- (root2hostname root1, root2hostname root2)
>+- in
>+- let def_descr = "Left to Right" in
>+- let descr =
>+- if init || loc1 = loc2 then def_descr else
>+- Printf.sprintf "from %s to %s" loc1 loc2 in
>+- let left =
>+- actionMenu#add_image_item ~key:GdkKeysyms._greater ~callback:rightAction
>+- ~image:((GMisc.image ~stock:`GO_FORWARD ~icon_size:`MENU ())#coerce)
>+- ~name:("Propagate " ^ def_descr) ("Propagate " ^ descr) in
>+- grAdd grAction left;
>+- left#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._greater;
>+- left#add_accelerator ~group:accel_group GdkKeysyms._period;
>+-
>+- let def_descl = "Right to Left" in
>+- let descl =
>+- if init || loc1 = loc2 then def_descl else
>+- Printf.sprintf "from %s to %s"
>+- (Unicode.protect loc2) (Unicode.protect loc1) in
>+- let right =
>+- actionMenu#add_image_item ~key:GdkKeysyms._less ~callback:leftAction
>+- ~image:((GMisc.image ~stock:`GO_BACK ~icon_size:`MENU ())#coerce)
>+- ~name:("Propagate " ^ def_descl) ("Propagate " ^ descl) in
>+- grAdd grAction right;
>+- right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._less;
>+- right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._comma;
>+-
>+- let skip =
>+- actionMenu#add_image_item ~key:GdkKeysyms._slash ~callback:questionAction
>+- ~image:((GMisc.image ~stock:`NO ~icon_size:`MENU ())#coerce)
>+- "Do _Not Propagate Changes" in
>+- grAdd grAction skip;
>+- skip#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._minus;
>+-
>+- let merge =
>+- actionMenu#add_image_item ~key:GdkKeysyms._m ~callback:mergeAction
>+- ~image:((GMisc.image ~stock:`ADD ~icon_size:`MENU ())#coerce)
>+- "_Merge the Files" in
>+- grAdd grAction merge;
>+- (* merge#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._m; *)
>+-
>+- (* Override actions *)
>+- ignore (actionMenu#add_separator ());
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ ->
>+- Recon.setDirection ri `Replica1ToReplica2 `Prefer))
>+- "Resolve Conflicts in Favor of First Root");
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ ->
>+- Recon.setDirection ri `Replica2ToReplica1 `Prefer))
>+- "Resolve Conflicts in Favor of Second Root");
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ ->
>+- Recon.setDirection ri `Newer `Prefer))
>+- "Resolve Conflicts in Favor of Most Recently Modified");
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ ->
>+- Recon.setDirection ri `Older `Prefer))
>+- "Resolve Conflicts in Favor of Least Recently Modified");
>+- ignore (actionMenu#add_separator ());
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ -> Recon.setDirection ri `Newer `Force))
>+- "Force Newer Files to Replace Older Ones");
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ -> Recon.setDirection ri `Older `Force))
>+- "Force Older Files to Replace Newer Ones");
>+- ignore (actionMenu#add_separator ());
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ -> Recon.revertToDefaultDirection ri))
>+- "_Revert to Unison's Recommendations");
>+- grAdd grAction
>+- (actionMenu#add_item
>+- ~callback:(fun () ->
>+- doAction (fun ri _ -> Recon.setDirection ri `Merge `Force))
>+- "Revert to the Merging Default, if Available");
>+-
>+- (* Diff *)
>+- ignore (actionMenu#add_separator ());
>+- grAdd grDiff (actionMenu#add_image_item ~key:GdkKeysyms._d ~callback:diffCmd
>+- ~image:((GMisc.image ~stock:`DIALOG_INFO ~icon_size:`MENU ())#coerce)
>+- "Show _Diffs");
>+-
>+- (* Details *)
>+- grAdd grDetail
>+- (actionMenu#add_image_item ~key:GdkKeysyms._i ~callback:showDetCommand
>+- ~image:((GMisc.image ~stock:`INFO ~icon_size:`MENU ())#coerce)
>+- "Detailed _Information")
>+-
>+- in
>+- buildActionMenu true;
>+-
>+- (*********************************************************************
>+- Synchronization menu
>+- *********************************************************************)
>+-
>+- grAdd grGo
>+- (fileMenu#add_image_item ~key:GdkKeysyms._g
>+- ~image:(GMisc.image ~stock:`EXECUTE ~icon_size:`MENU () :> GObj.widget)
>+- ~callback:(fun () -> getLock synchronize)
>+- "_Go");
>+- grAdd grRescan
>+- (fileMenu#add_image_item ~key:GdkKeysyms._r
>+- ~image:(GMisc.image ~stock:`REFRESH ~icon_size:`MENU () :> GObj.widget)
>+- ~callback:(fun () -> reloadProfile(); detectCmd())
>+- "_Rescan");
>+- grAdd grRescan
>+- (fileMenu#add_item ~key:GdkKeysyms._a
>+- ~callback:(fun () ->
>+- reloadProfile();
>+- Prefs.set Globals.batch true;
>+- detectCmd())
>+- "_Detect Updates and Proceed (Without Waiting)");
>+- grAdd grRescan
>+- (fileMenu#add_item ~key:GdkKeysyms._f
>+- ~callback:(
>+- fun () ->
>+- let rec loop i acc =
>+- if i >= Array.length (!theState) then acc else
>+- let notok =
>+- (match !theState.(i).whatHappened with
>+- None-> true
>+- | Some(Util.Failed _, _) -> true
>+- | Some(Util.Succeeded, _) -> false)
>+- || match !theState.(i).ri.replicas with
>+- Problem _ -> true
>+- | Different diff -> isConflict diff.direction in
>+- if notok then loop (i+1) (i::acc)
>+- else loop (i+1) (acc) in
>+- let failedindices = loop 0 [] in
>+- let failedpaths =
>+- Safelist.map (fun i -> !theState.(i).ri.path1) failedindices in
>+- debug (fun()-> Util.msg "Rescaning with paths = %s\n"
>+- (String.concat ", " (Safelist.map
>+- (fun p -> "'"^(Path.toString p)^"'")
>+- failedpaths)));
>+- let paths = Prefs.read Globals.paths in
>+- let confirmBigDeletes = Prefs.read Globals.confirmBigDeletes in
>+- Prefs.set Globals.paths failedpaths;
>+- Prefs.set Globals.confirmBigDeletes false;
>+- (* Modifying global paths does not play well with filesystem
>+- monitoring, so we disable it. *)
>+- unsynchronizedPaths := None;
>+- detectCmd();
>+- Prefs.set Globals.paths paths;
>+- Prefs.set Globals.confirmBigDeletes confirmBigDeletes;
>+- unsynchronizedPaths := None)
>+- "Re_check Unsynchronized Items");
>+-
>+- ignore (fileMenu#add_separator ());
>+-
>+- grAdd grRescan
>+- (fileMenu#add_image_item ~key:GdkKeysyms._p
>+- ~callback:(fun _ ->
>+- match getProfile false with
>+- None -> ()
>+- | Some(p) -> clearMainWindow (); loadProfile p false; detectCmd ())
>+- ~image:(GMisc.image ~stock:`OPEN ~icon_size:`MENU () :> GObj.widget)
>+- "Change _Profile...");
>+-
>+- let fastProf name key =
>+- grAdd grRescan
>+- (fileMenu#add_item ~key:key
>+- ~callback:(fun _ ->
>+- if System.file_exists (Prefs.profilePathname name) then begin
>+- Trace.status ("Loading profile " ^ name);
>+- loadProfile name false; detectCmd ()
>+- end else
>+- Trace.status ("Profile " ^ name ^ " not found"))
>+- ("Select profile " ^ name)) in
>+-
>+- let fastKeysyms =
>+- [| GdkKeysyms._0; GdkKeysyms._1; GdkKeysyms._2; GdkKeysyms._3;
>+- GdkKeysyms._4; GdkKeysyms._5; GdkKeysyms._6; GdkKeysyms._7;
>+- GdkKeysyms._8; GdkKeysyms._9 |] in
>+-
>+- Array.iteri
>+- (fun i v -> match v with
>+- None -> ()
>+- | Some(profile, info) ->
>+- fastProf profile fastKeysyms.(i))
>+- Uicommon.profileKeymap;
>+-
>+- ignore (fileMenu#add_separator ());
>+- ignore (fileMenu#add_item
>+- ~callback:(fun _ -> statWin#show ()) "Show _Statistics");
>+-
>+- ignore (fileMenu#add_separator ());
>+- let quit =
>+- fileMenu#add_image_item
>+- ~key:GdkKeysyms._q ~callback:safeExit
>+- ~image:((GMisc.image ~stock:`QUIT ~icon_size:`MENU ())#coerce)
>+- "_Quit"
>+- in
>+- quit#add_accelerator ~group:accel_group ~modi:[`CONTROL] GdkKeysyms._q;
>+-
>+- (*********************************************************************
>+- Expert menu
>+- *********************************************************************)
>+- if Prefs.read Uicommon.expert then begin
>+- let (expertMenu, _) = add_submenu "Expert" in
>+-
>+- let addDebugToggle modname =
>+- ignore (expertMenu#add_check_item ~active:(Trace.enabled modname)
>+- ~callback:(fun b -> Trace.enable modname b)
>+- ("Debug '" ^ modname ^ "'")) in
>+-
>+- addDebugToggle "all";
>+- addDebugToggle "verbose";
>+- addDebugToggle "update";
>+-
>+- ignore (expertMenu#add_separator ());
>+- ignore (expertMenu#add_item
>+- ~callback:(fun () ->
>+- Printf.fprintf stderr "\nGC stats now:\n";
>+- Gc.print_stat stderr;
>+- Printf.fprintf stderr "\nAfter major collection:\n";
>+- Gc.full_major(); Gc.print_stat stderr;
>+- flush stderr)
>+- "Show memory/GC stats")
>+- end;
>+-
>+- (*********************************************************************
>+- Finish up
>+- *********************************************************************)
>+- grDisactivateAll ();
>+-
>+- updateFromProfile :=
>+- (fun () ->
>+- displayNewProfileLabel ();
>+- setMainWindowColumnHeaders (Uicommon.roots2string ());
>+- buildActionMenu false);
>+-
>+-
>+- ignore (toplevelWindow#event#connect#delete ~callback:
>+- (fun _ -> safeExit (); true));
>+- toplevelWindow#show ();
>+- fun () ->
>+- !updateFromProfile ();
>+- mainWindow#misc#grab_focus ();
>+- detectCmd ()
>+-
>+-
>+-(*********************************************************************
>+- STARTUP
>+- *********************************************************************)
>+-
>+-let start _ =
>+- begin try
>+- (* Initialize the GTK library *)
>+- ignore (GMain.Main.init ());
>+-
>+- Util.warnPrinter :=
>+- Some (fun msg -> warnBox ~parent:(toplevelWindow ()) "Warning" msg);
>+-
>+- GtkSignal.user_handler :=
>+- (fun exn ->
>+- match exn with
>+- Util.Transient(s) | Util.Fatal(s) -> fatalError s
>+- | exn -> fatalError (Uicommon.exn2string exn));
>+-
>+- (* Ask the Remote module to call us back at regular intervals during
>+- long network operations. *)
>+- let rec tick () =
>+- gtk_sync true;
>+- Lwt_unix.sleep 0.05 >>= tick
>+- in
>+- ignore_result (tick ());
>+-
>+- let prepDebug () =
>+- if Sys.os_type = "Win32" then
>+- (* As a side-effect, this allocates a console if the process doesn't
>+- have one already. This call is here only for the side-effect,
>+- because debugging output is produced on stderr and the GUI will
>+- crash if there is no stderr. *)
>+- try ignore (System.terminalStateFunctions ())
>+- with Unix.Unix_error _ -> ()
>+- in
>+-
>+- Os.createUnisonDir();
>+- Uicommon.scanProfiles();
>+- let detectCmd = createToplevelWindow() in
>+-
>+- Uicommon.uiInit
>+- ~prepDebug
>+- ~reportError:fatalError
>+- ~tryAgainOrQuit
>+- ~displayWaitMessage
>+- ~getProfile:(fun () -> getProfile true)
>+- ~getFirstRoot
>+- ~getSecondRoot
>+- ~termInteract
>+- ();
>+- detectCmd ();
>+-
>+- (* Display the ui *)
>+-(*JV: not useful, as Unison does not handle any signal
>+- ignore (GMain.Timeout.add 500 (fun _ -> true));
>+- (* Hack: this allows signals such as SIGINT to be
>+- handled even when Gtk is waiting for events *)
>+-*)
>+- GMain.Main.main ()
>+- with
>+- Util.Transient(s) | Util.Fatal(s) -> fatalError s
>+- | exn -> fatalError (Uicommon.exn2string exn)
>+- end
>+-
>+-end (* module Private *)
>+-
>+-
>+-(*********************************************************************
>+- UI SELECTION
>+- *********************************************************************)
>+-
>+-module Body : Uicommon.UI = struct
>+-
>+-let start = function
>+- Uicommon.Text -> Uitext.Body.start Uicommon.Text
>+- | Uicommon.Graphic ->
>+- let displayAvailable =
>+- Util.osType = `Win32
>+- ||
>+- try System.getenv "DISPLAY" <> "" with Not_found -> false
>+- in
>+- if displayAvailable then Private.start Uicommon.Graphic
>+- else
>+- Util.warn "DISPLAY not set or empty; starting the Text UI\n";
>+- Uitext.Body.start Uicommon.Text
>+-
>+-let defaultUi = Uicommon.Graphic
>+-
>+-end (* module Body *)
>+Index: unison-2.51.5/src/uigtk3.ml
>+===================================================================
>+--- /dev/null
>++++ unison-2.51.5/src/uigtk3.ml
>+@@ -0,0 +1,4239 @@
>++(* Unison file synchronizer: src/uigtk3.ml *)
>++(* Copyright 1999-2020, Benjamin C. Pierce
>++
>++ This program 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 3 of the License, or
>++ (at your option) any later version.
>++
>++ This program is distributed in the hope that it will be useful,
>++ but WITHOUT ANY WARRANTY; without even the implied warranty of
>++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
>++ GNU General Public License for more details.
>++
>++ You should have received a copy of the GNU General Public License
>++ along with this program. If not, see <http://www.gnu.org/licenses/>.
>++*)
>++
>++
>++open Common
>++open Lwt
>++
>++module Private = struct
>++
>++let debug = Trace.debug "ui"
>++
>++let myNameCapitalized = String.capitalize_ascii Uutil.myName
>++
>++(**********************************************************************
>++ LOW-LEVEL STUFF
>++ **********************************************************************)
>++
>++(**********************************************************************
>++ Some message strings (build them here because they look ugly in the
>++ middle of other code.
>++ **********************************************************************)
>++
>++let tryAgainMessage =
>++ Printf.sprintf
>++"You can use %s to synchronize a local directory with another local directory,
>++or with a remote directory.
>++
>++Please enter the first (local) directory that you want to synchronize."
>++myNameCapitalized
>++
>++(* ---- *)
>++
>++let helpmessage = Printf.sprintf
>++"%s can synchronize a local directory with another local directory, or with
>++a directory on a remote machine.
>++
>++To synchronize with a local directory, just enter the file name.
>++
>++To synchronize with a remote directory, you must first choose a protocol
>++that %s will use to connect to the remote machine. Each protocol has
>++different requirements:
>++
>++1) To synchronize using SSH, there must be an SSH client installed on
>++this machine and an SSH server installed on the remote machine. You
>++must enter the host to connect to, a user name (if different from
>++your user name on this machine), and the directory on the remote machine
>++(relative to your home directory on that machine).
>++
>++2) To synchronize using RSH, there must be an RSH client installed on
>++this machine and an RSH server installed on the remote machine. You
>++must enter the host to connect to, a user name (if different from
>++your user name on this machine), and the directory on the remote machine
>++(relative to your home directory on that machine).
>++
>++3) To synchronize using %s's socket protocol, there must be a %s
>++server running on the remote machine, listening to the port that you
>++specify here. (Use \"%s -socket xxx\" on the remote machine to
>++start the %s server.) You must enter the host, port, and the directory
>++on the remote machine (relative to the working directory of the
>++%s server running on that machine)."
>++myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized
>++
>++(**********************************************************************
>++ Font preferences
>++ **********************************************************************)
>++
>++let fontMonospace = lazy (Pango.Font.from_string "monospace")
>++let fontBold = lazy (Pango.Font.from_string "bold")
>++let fontItalic = lazy (Pango.Font.from_string "italic")
>++
>++(**********************************************************************
>++ Unison icon
>++ **********************************************************************)
>++
>++(* This does not work with the current version of Lablgtk, due to a bug
>++let icon =
>++ GdkPixbuf.from_data ~width:48 ~height:48 ~has_alpha:true
>++ (Gpointer.region_of_bytes Pixmaps.icon_data)
>++*)
>++let icon =
>++ let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in
>++ let pxs = GdkPixbuf.get_pixels p in
>++ (* This little hack is here to support compiling with lablgtk versions both
>++ < 2.18.6 and >= 2.18.6 *)
>++ String.iteri (fun i c -> Gpointer.set_byte pxs ~pos:i (Char.code c)) Pixmaps.icon_data;
>++ p
>++
>++let leftPtrWatch =
>++ lazy (Gdk.Cursor.create `WATCH)
>++
>++let make_busy w =
>++ if Util.osType <> `Win32 then
>++ Gdk.Window.set_cursor w#misc#window (Lazy.force leftPtrWatch)
>++let make_interactive w =
>++ if Util.osType <> `Win32 then
>++ (* HACK: setting the cursor to NULL restore the default cursor *)
>++ Gdk.Window.set_cursor w#misc#window (Obj.magic Gpointer.boxed_null)
>++
>++(*********************************************************************
>++ UI state variables
>++ *********************************************************************)
>++
>++type stateItem = { mutable ri : reconItem;
>++ mutable bytesTransferred : Uutil.Filesize.t;
>++ mutable bytesToTransfer : Uutil.Filesize.t;
>++ mutable whatHappened : (Util.confirmation * string option) option}
>++let theState = ref [||]
>++let unsynchronizedPaths = ref None
>++
>++(* ---- *)
>++
>++let theToplevelWindow = ref None
>++let setToplevelWindow w = theToplevelWindow := Some w
>++let toplevelWindow () =
>++ match !theToplevelWindow with
>++ Some w -> w
>++ | None -> raise (Util.Fatal "Main window not initialized; check your DISPLAY setup")
>++
>++(*********************************************************************
>++ Lock management
>++ *********************************************************************)
>++
>++let busy = ref false
>++
>++let getLock f =
>++ if !busy then
>++ Trace.status "Synchronizer is busy, please wait.."
>++ else begin
>++ busy := true; f (); busy := false
>++ end
>++
>++(**********************************************************************
>++ Miscellaneous
>++ **********************************************************************)
>++
>++let sync_action = ref None
>++
>++let last = ref (0.)
>++
>++let gtk_sync forced =
>++ let t = Unix.gettimeofday () in
>++ if !last = 0. || forced || t -. !last > 0.05 then begin
>++ last := t;
>++ begin match !sync_action with
>++ Some f -> f ()
>++ | None -> ()
>++ end;
>++ while Glib.Main.iteration false do () done
>++ end
>++
>++(**********************************************************************
>++ CHARACTER SET TRANSCODING
>++***********************************************************************)
>++
>++(* Transcodage from Microsoft Windows Codepage 1252 to Unicode *)
>++
>++(* Unison currently uses the "ASCII" Windows filesystem API. With
>++ this API, filenames are encoded using a proprietary character
>++ encoding. This encoding depends on the Windows setup, but in
>++ Western Europe, the Windows Codepage 1252 is usually used.
>++ GTK, on the other hand, uses the UTF-8 encoding. This code perform
>++ the translation from Codepage 1252 to UTF-8. A call to [transcode]
>++ should be wrapped around every string below that might contain
>++ non-ASCII characters. *)
>++
>++let code =
>++ [| 0x0020; 0x0001; 0x0002; 0x0003; 0x0004; 0x0005; 0x0006; 0x0007;
>++ 0x0008; 0x0009; 0x000A; 0x000B; 0x000C; 0x000D; 0x000E; 0x000F;
>++ 0x0010; 0x0011; 0x0012; 0x0013; 0x0014; 0x0015; 0x0016; 0x0017;
>++ 0x0018; 0x0019; 0x001A; 0x001B; 0x001C; 0x001D; 0x001E; 0x001F;
>++ 0x0020; 0x0021; 0x0022; 0x0023; 0x0024; 0x0025; 0x0026; 0x0027;
>++ 0x0028; 0x0029; 0x002A; 0x002B; 0x002C; 0x002D; 0x002E; 0x002F;
>++ 0x0030; 0x0031; 0x0032; 0x0033; 0x0034; 0x0035; 0x0036; 0x0037;
>++ 0x0038; 0x0039; 0x003A; 0x003B; 0x003C; 0x003D; 0x003E; 0x003F;
>++ 0x0040; 0x0041; 0x0042; 0x0043; 0x0044; 0x0045; 0x0046; 0x0047;
>++ 0x0048; 0x0049; 0x004A; 0x004B; 0x004C; 0x004D; 0x004E; 0x004F;
>++ 0x0050; 0x0051; 0x0052; 0x0053; 0x0054; 0x0055; 0x0056; 0x0057;
>++ 0x0058; 0x0059; 0x005A; 0x005B; 0x005C; 0x005D; 0x005E; 0x005F;
>++ 0x0060; 0x0061; 0x0062; 0x0063; 0x0064; 0x0065; 0x0066; 0x0067;
>++ 0x0068; 0x0069; 0x006A; 0x006B; 0x006C; 0x006D; 0x006E; 0x006F;
>++ 0x0070; 0x0071; 0x0072; 0x0073; 0x0074; 0x0075; 0x0076; 0x0077;
>++ 0x0078; 0x0079; 0x007A; 0x007B; 0x007C; 0x007D; 0x007E; 0x007F;
>++ 0x20AC; 0x1234; 0x201A; 0x0192; 0x201E; 0x2026; 0x2020; 0x2021;
>++ 0x02C6; 0x2030; 0x0160; 0x2039; 0x0152; 0x1234; 0x017D; 0x1234;
>++ 0x1234; 0x2018; 0x2019; 0x201C; 0x201D; 0x2022; 0x2013; 0x2014;
>++ 0x02DC; 0x2122; 0x0161; 0x203A; 0x0153; 0x1234; 0x017E; 0x0178;
>++ 0x00A0; 0x00A1; 0x00A2; 0x00A3; 0x00A4; 0x00A5; 0x00A6; 0x00A7;
>++ 0x00A8; 0x00A9; 0x00AA; 0x00AB; 0x00AC; 0x00AD; 0x00AE; 0x00AF;
>++ 0x00B0; 0x00B1; 0x00B2; 0x00B3; 0x00B4; 0x00B5; 0x00B6; 0x00B7;
>++ 0x00B8; 0x00B9; 0x00BA; 0x00BB; 0x00BC; 0x00BD; 0x00BE; 0x00BF;
>++ 0x00C0; 0x00C1; 0x00C2; 0x00C3; 0x00C4; 0x00C5; 0x00C6; 0x00C7;
>++ 0x00C8; 0x00C9; 0x00CA; 0x00CB; 0x00CC; 0x00CD; 0x00CE; 0x00CF;
>++ 0x00D0; 0x00D1; 0x00D2; 0x00D3; 0x00D4; 0x00D5; 0x00D6; 0x00D7;
>++ 0x00D8; 0x00D9; 0x00DA; 0x00DB; 0x00DC; 0x00DD; 0x00DE; 0x00DF;
>++ 0x00E0; 0x00E1; 0x00E2; 0x00E3; 0x00E4; 0x00E5; 0x00E6; 0x00E7;
>++ 0x00E8; 0x00E9; 0x00EA; 0x00EB; 0x00EC; 0x00ED; 0x00EE; 0x00EF;
>++ 0x00F0; 0x00F1; 0x00F2; 0x00F3; 0x00F4; 0x00F5; 0x00F6; 0x00F7;
>++ 0x00F8; 0x00F9; 0x00FA; 0x00FB; 0x00FC; 0x00FD; 0x00FE; 0x00FF |]
>++
>++let rec transcodeRec buf s i l =
>++ if i < l then begin
>++ let c = code.(Char.code s.[i]) in
>++ if c < 0x80 then
>++ Buffer.add_char buf (Char.chr c)
>++ else if c < 0x800 then begin
>++ Buffer.add_char buf (Char.chr (c lsr 6 + 0xC0));
>++ Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))
>++ end else if c < 0x10000 then begin
>++ Buffer.add_char buf (Char.chr (c lsr 12 + 0xE0));
>++ Buffer.add_char buf (Char.chr ((c lsr 6) land 0x3f + 0x80));
>++ Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))
>++ end;
>++ transcodeRec buf s (i + 1) l
>++ end
>++
>++let transcodeDoc s =
>++ let buf = Buffer.create 1024 in
>++ transcodeRec buf s 0 (String.length s);
>++ Buffer.contents buf
>++
>++(****)
>++
>++let escapeMarkup s = Glib.Markup.escape_text s
>++
>++let transcodeFilename s =
>++ if Prefs.read Case.unicodeEncoding then
>++ Unicode.protect s
>++ else if Util.osType = `Win32 then transcodeDoc s else
>++ try
>++ Glib.Convert.filename_to_utf8 s
>++ with Glib.Convert.Error _ ->
>++ Unicode.protect s
>++
>++let transcode s =
>++ if Prefs.read Case.unicodeEncoding then
>++ Unicode.protect s
>++ else
>++ try
>++ Glib.Convert.locale_to_utf8 s
>++ with Glib.Convert.Error _ ->
>++ Unicode.protect s
>++
>++(**********************************************************************
>++ USEFUL LOW-LEVEL WIDGETS
>++ **********************************************************************)
>++
>++class scrolled_text ?editable ?shadow_type ?word_wrap
>++ ~width ~height ?packing ?show
>++ () =
>++ let sw =
>++ GBin.scrolled_window ?packing ~show:false
>++ ?shadow_type ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
>++ in
>++ let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in
>++ object
>++ inherit GObj.widget_full sw#as_widget
>++ method text = text
>++ method insert s = text#buffer#set_text s;
>++ method show () = sw#misc#show ()
>++ initializer
>++ text#misc#set_size_chars ~height ~width ();
>++ if show <> Some false then sw#misc#show ()
>++ end
>++
>++(* ------ *)
>++
>++(* Display a message in a window and wait for the user
>++ to hit the button. *)
>++let okBox ~parent ~title ~typ ~message =
>++ let t =
>++ GWindow.message_dialog
>++ ~parent ~title ~message_type:typ ~message ~modal:true
>++ ~buttons:GWindow.Buttons.ok () in
>++ ignore (t#run ()); t#destroy ()
>++
>++(* ------ *)
>++
>++let primaryText msg =
>++ Printf.sprintf "%s"
>++ (escapeMarkup msg)
>++
>++(* twoBox: Display a message in a window and wait for the user
>++ to hit one of two buttons. Return true if the first button is
>++ chosen, false if the second button is chosen. *)
>++let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message =
>++ let t =
>++ GWindow.dialog ~parent ~border_width:6 ~modal:true
>++ ~resizable:false () in
>++ t#vbox#set_spacing 12;
>++ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>++ ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG
>++ ~yalign:0. ~packing:h1#pack ());
>++ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>++ ignore (GMisc.label
>++ ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)
>++ ~selectable:true ~yalign:0. ~packing:v1#add ());
>++ t#add_button_stock bstock `NO;
>++ t#add_button_stock astock `YES;
>++ t#set_default_response `NO;
>++ t#show();
>++ let res = t#run () in
>++ t#destroy ();
>++ res = `YES
>++
>++(* ------ *)
>++
>++(* Avoid recursive invocations of the function below (a window receives
>++ delete events even when it is not sensitive) *)
>++let inExit = ref false
>++
>++let doExit () = Lwt_unix.run (Update.unlockArchives ()); exit 0
>++
>++let safeExit () =
>++ if not !inExit then begin
>++ inExit := true;
>++ if not !busy then exit 0 else
>++ if twoBox ~parent:(toplevelWindow ()) ~title:"Premature exit"
>++ ~astock:`YES ~bstock:`NO
>++ "Unison is working, exit anyway ?"
>++ then exit 0;
>++ inExit := false
>++ end
>++
>++(* ------ *)
>++
>++(* warnBox: Display a warning message in a window and wait (unless
>++ we're in batch mode) for the user to hit "OK" or "Exit". *)
>++let warnBox ~parent title message =
>++ let message = transcode message in
>++ if Prefs.read Globals.batch then begin
>++ (* In batch mode, just pop up a window and go ahead *)
>++ let t =
>++ GWindow.dialog ~parent
>++ ~border_width:6 ~modal:true ~resizable:false () in
>++ t#vbox#set_spacing 12;
>++ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>++ ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
>++ ~yalign:0. ~packing:h1#pack ());
>++ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>++ ignore (GMisc.label ~markup:(primaryText title ^ "\n\n" ^
>++ escapeMarkup message)
>++ ~selectable:true ~yalign:0. ~packing:v1#add ());
>++ t#add_button_stock `CLOSE `CLOSE;
>++ t#set_default_response `CLOSE;
>++ ignore (t#connect#response ~callback:(fun _ -> t#destroy ()));
>++ t#show ()
>++ end else begin
>++ inExit := true;
>++ let ok =
>++ twoBox ~parent:(toplevelWindow ()) ~title ~astock:`OK ~bstock:`QUIT
>++ message in
>++ if not(ok) then doExit ();
>++ inExit := false
>++ end
>++
>++(****)
>++
>++let accel_paths = Hashtbl.create 17
>++let underscore_re = Str.regexp_string "_"
>++class ['a] gMenuFactory
>++ ?(accel_group=GtkData.AccelGroup.create ())
>++ ?(accel_path="<DEFAULT ROOT>/")
>++ ?(accel_modi=[`CONTROL])
>++ ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) =
>++ object (self)
>++ val menu_shell : #GMenu.menu_shell = menu_shell
>++ val group = accel_group
>++ val m = accel_modi
>++ val flags = (accel_flags:Gtk.Tags.accel_flag list)
>++ val accel_path = accel_path
>++ method menu = menu_shell
>++ method accel_group = group
>++ method accel_path = accel_path
>++ method private bind
>++ ?(modi=m) ?key ?callback label ?(name=label) (item : GMenu.menu_item) =
>++ menu_shell#append item;
>++ let accel_path = accel_path ^ name in
>++ let accel_path = Str.global_replace underscore_re "" accel_path in
>++ (* Default accel path value *)
>++ if not (Hashtbl.mem accel_paths accel_path) then begin
>++ Hashtbl.add accel_paths accel_path ();
>++ GtkData.AccelMap.add_entry accel_path ?key ~modi
>++ end;
>++ (* Register this accel path *)
>++ GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group;
>++ Gaux.may callback ~f:(fun callback -> item#connect#activate ~callback)
>++ method add_item ?key ?modi ?callback ?submenu label =
>++ let item = GMenu.menu_item ~use_mnemonic:true ~label () in
>++ self#bind ?modi ?key ?callback label item;
>++ Gaux.may (submenu : GMenu.menu option) ~f:item#set_submenu;
>++ item
>++ method add_image_item ?(image : GObj.widget option)
>++ ?modi ?key ?callback ?stock ?name label =
>++ (* GTK 3 does not provide image menu items (there is a way to
>++ manually create a workaround but that does not work with
>++ lablgtk. Let's create a regular menu item instead. *)
>++ let item =
>++ GMenu.menu_item ~use_mnemonic:true ~label () in
>++ match stock with
>++ | None ->
>++ self#bind ?modi ?key ?callback label ?name item;
>++ item
>++ | Some s ->
>++ try
>++ let st = GtkStock.Item.lookup s in
>++ self#bind
>++ ?modi ?key:(if st.GtkStock.keyval=0 then key else None)
>++ ?callback label ?name item;
>++ item
>++ with Not_found -> item
>++
>++ method add_check_item ?active ?modi ?key ?callback label =
>++ let item = GMenu.check_menu_item ~label ~use_mnemonic:true ?active () in
>++ self#bind label ?modi ?key
>++ ?callback:(Gaux.may_map callback ~f:(fun f () -> f item#active))
>++ (item : GMenu.check_menu_item :> GMenu.menu_item);
>++ item
>++ method add_separator () = GMenu.separator_item ~packing:menu_shell#append ()
>++ method add_submenu label =
>++ let item = GMenu.menu_item ~use_mnemonic:true ~label () in
>++ self#bind label item;
>++ (GMenu.menu ~packing:item#set_submenu (), item)
>++ method replace_submenu (item : GMenu.menu_item) =
>++ GMenu.menu ~packing:item#set_submenu ()
>++end
>++
>++(**********************************************************************
>++ HIGHER-LEVEL WIDGETS
>++***********************************************************************)
>++
>++(*class stats width height =
>++ let pixmap = GDraw.pixmap ~width ~height () in
>++ let area =
>++ pixmap#set_foreground `WHITE;
>++ pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
>++ GMisc.pixmap pixmap ~width ~height ~xpad:4 ~ypad:8 ()
>++ in
>++ object (self)
>++ inherit GObj.widget_full area#as_widget
>++ val mutable maxim = ref 0.
>++ val mutable scale = ref 1.
>++ val mutable min_scale = 1.
>++ val values = Array.make width 0.
>++ val mutable active = false
>++
>++ method redraw () =
>++ scale := min_scale;
>++ while !maxim > !scale do
>++ scale := !scale *. 1.5
>++ done;
>++ pixmap#set_foreground `WHITE;
>++ pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
>++ pixmap#set_foreground `BLACK;
>++ for i = 0 to width - 1 do
>++ self#rect i values.(max 0 (i - 1)) values.(i)
>++ done
>++
>++ method activate a = active <- a; if a then self#redraw ()
>++
>++ method scale h = truncate ((float height) *. h /. !scale)
>++
>++ method private rect i v' v =
>++ let h = self#scale v in
>++ let h' = self#scale v' in
>++ let h1 = min h' h in
>++ let h2 = max h' h in
>++ pixmap#set_foreground `BLACK;
>++ pixmap#rectangle
>++ ~filled:true ~x:i ~y:(height - h1) ~width:1 ~height:h1 ();
>++ for h = h1 + 1 to h2 do
>++ let v = truncate (65535. *. (float (h - h1) /. float (h2 - h1))) in
>++ let v = (v / 4096) * 4096 in (* Only use 16 gray levels *)
>++ pixmap#set_foreground (`RGB (v, v, v));
>++ pixmap#rectangle
>++ ~filled:true ~x:i ~y:(height - h) ~width:1 ~height:1 ();
>++ done
>++
>++ method push v =
>++ let need_max = values.(0) = !maxim in
>++ for i = 0 to width - 2 do
>++ values.(i) <- values.(i + 1)
>++ done;
>++ values.(width - 1) <- v;
>++ if need_max then begin
>++ maxim := 0.;
>++ for i = 0 to width - 1 do maxim := max !maxim values.(i) done
>++ end else
>++ maxim := max !maxim v;
>++ if active then begin
>++ let need_resize =
>++ !maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in
>++ if need_resize then
>++ self#redraw ()
>++ else begin
>++ pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap);
>++ pixmap#set_foreground `WHITE;
>++ pixmap#rectangle
>++ ~filled:true ~x:(width - 1) ~y:0 ~width:1 ~height ();
>++ self#rect (width - 1) values.(width - 2) values.(width - 1)
>++ end;
>++ area#misc#draw None
>++ end
>++ end
>++*)
>++let clientWritten = ref 0.
>++let serverWritten = ref 0.
>++let emitRate2 = ref 0.
>++let receiveRate2 = ref 0.
>++
>++let rate2str v =
>++ if v > 9.9e3 then begin
>++ if v > 9.9e6 then
>++ Format.sprintf "%1.0f MiB/s" (v /. 1e6)
>++ else if v > 999e3 then
>++ Format.sprintf "%1.1f MiB/s" (v /. 1e6)
>++ else
>++ Format.sprintf "%1.0f KiB/s" (v /. 1e3)
>++ end else begin
>++ if v > 990. then
>++ Format.sprintf "%1.1f KiB/s" (v /. 1e3)
>++ else if v > 99. then
>++ Format.sprintf "%1.2f KiB/s" (v /. 1e3)
>++ else
>++ " "
>++ end
>++
>++let mib = 1024. *. 1024.
>++let kib2str v =
>++ if v > 100_000_000. then
>++ Format.sprintf "%.0f MiB" (v /. mib)
>++ else if v > 1_000_000. then
>++ Format.sprintf "%.1f MiB" (v /. mib)
>++ else if v > 1024. then
>++ Format.sprintf "%.1f KiB" (v /. 1024.)
>++ else
>++ Format.sprintf "%.0f B" v
>++
>++let statistics () =
>++ let title = "Statistics" in
>++ let t = GWindow.dialog ~title () in
>++ let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
>++ t_dismiss#grab_default ();
>++ let dismiss () = t#misc#hide () in
>++ ignore (t_dismiss#connect#clicked ~callback:dismiss);
>++ ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));
>++
>++(* let emission = new stats 320 50 in
>++ t#vbox#pack ~expand:false ~padding:4 (emission :> GObj.widget);
>++ let reception = new stats 320 50 in
>++ t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);*)
>++
>++ let cols = new GTree.column_list in
>++ let c_1 = cols#add Gobject.Data.string in
>++ let c_client = cols#add Gobject.Data.string in
>++ let c_server = cols#add Gobject.Data.string in
>++ let c_total = cols#add Gobject.Data.string in
>++ let lst = GTree.list_store cols in
>++ let l = GTree.view ~model:lst ~enable_search:false ~packing:(t#vbox#add) () in
>++ l#selection#set_mode `NONE;
>++ ignore (l#append_column (GTree.view_column ~title:""
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_1]) ()));
>++ ignore (l#append_column (GTree.view_column ~title:"Client"
>++ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_client]) ()));
>++ ignore (l#append_column (GTree.view_column ~title:"Server"
>++ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_server]) ()));
>++ ignore (l#append_column (GTree.view_column ~title:"Total"
>++ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_total]) ()));
>++ let rate_row = lst#append () in
>++ ignore (lst#set rate_row c_1 "Reception rate");
>++ let receive_row = lst#append () in
>++ ignore (lst#set receive_row c_1 "Data received");
>++ let data_row = lst#append () in
>++ ignore (lst#set data_row c_1 "File data written");
>++(*
>++ ignore (t#event#connect#map ~callback:(fun _ ->
>++ emission#activate true;
>++ reception#activate true;
>++ false));
>++ ignore (t#event#connect#unmap ~callback:(fun _ ->
>++ emission#activate false;
>++ reception#activate false;
>++ false));*)
>++
>++ let delay = 0.5 in
>++ let a = 0.5 in
>++ let b = 0.8 in
>++
>++ let emittedBytes = ref 0. in
>++ let emitRate = ref 0. in
>++ let receivedBytes = ref 0. in
>++ let receiveRate = ref 0. in
>++
>++ let stopCounter = ref 0 in
>++
>++ let updateTable () =
>++ let row = rate_row in
>++ lst#set ~row ~column:c_client (rate2str !receiveRate2);
>++ lst#set ~row ~column:c_server (rate2str !emitRate2);
>++ lst#set ~row ~column:c_total (rate2str (!receiveRate2 +. !emitRate2));
>++ let row = receive_row in
>++ lst#set ~row ~column:c_client (kib2str !receivedBytes);
>++ lst#set ~row ~column:c_server (kib2str !emittedBytes);
>++ lst#set ~row ~column:c_total (kib2str (!receivedBytes +. !emittedBytes));
>++ let row = data_row in
>++ lst#set ~row ~column:c_client (kib2str !clientWritten);
>++ lst#set ~row ~column:c_server (kib2str !serverWritten);
>++ lst#set ~row ~column:c_total (kib2str (!clientWritten +. !serverWritten))
>++ in
>++ let timeout _ =
>++ emitRate :=
>++ a *. !emitRate +.
>++ (1. -. a) *. (!Remote.emittedBytes -. !emittedBytes) /. delay;
>++ emitRate2 :=
>++ b *. !emitRate2 +.
>++ (1. -. b) *. (!Remote.emittedBytes -. !emittedBytes) /. delay;
>++(* emission#push !emitRate;*)
>++ receiveRate :=
>++ a *. !receiveRate +.
>++ (1. -. a) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;
>++ receiveRate2 :=
>++ b *. !receiveRate2 +.
>++ (1. -. b) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;
>++(* reception#push !receiveRate;*)
>++ emittedBytes := !Remote.emittedBytes;
>++ receivedBytes := !Remote.receivedBytes;
>++ if !stopCounter > 0 then decr stopCounter;
>++ if !stopCounter = 0 then begin
>++ emitRate2 := 0.; receiveRate2 := 0.;
>++ end;
>++ updateTable ();
>++ !stopCounter <> 0
>++ in
>++ let startStats () =
>++ if !stopCounter = 0 then begin
>++ emittedBytes := !Remote.emittedBytes;
>++ receivedBytes := !Remote.receivedBytes;
>++ stopCounter := -1;
>++ ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.))
>++ ~callback:timeout)
>++ end else
>++ stopCounter := -1
>++ in
>++ let stopStats () = stopCounter := 10 in
>++ (t, startStats, stopStats)
>++
>++(* ------ *)
>++
>++let fatalError message =
>++ let () =
>++ try Trace.log (message ^ "\n")
>++ with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *)
>++ let title = "Fatal error" in
>++ let t =
>++ GWindow.dialog ~parent:(toplevelWindow ())
>++ ~border_width:6 ~modal:true ~resizable:false () in
>++ t#vbox#set_spacing 12;
>++ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>++ ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG
>++ ~yalign:0. ~packing:h1#pack ());
>++ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>++ ignore (GMisc.label
>++ ~markup:(primaryText title ^ "\n\n" ^
>++ escapeMarkup (transcode message))
>++ ~line_wrap:true ~selectable:true ~yalign:0. ~packing:v1#add ());
>++ t#add_button_stock `QUIT `QUIT;
>++ t#set_default_response `QUIT;
>++ t#show(); ignore (t#run ()); t#destroy ();
>++ exit 1
>++
>++(* ------ *)
>++
>++let tryAgainOrQuit = fatalError
>++
>++(* ------ *)
>++
>++let getFirstRoot () =
>++ let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
>++ ~modal:true ~resizable:true () in
>++ t#misc#grab_focus ();
>++
>++ let hb = GPack.hbox
>++ ~packing:(t#vbox#pack ~expand:false ~padding:15) () in
>++ ignore(GMisc.label ~text:tryAgainMessage
>++ ~justify:`LEFT
>++ ~packing:(hb#pack ~expand:false ~padding:15) ());
>++
>++ let f1 = GPack.hbox ~spacing:4
>++ ~packing:(t#vbox#pack ~expand:true ~padding:4) () in
>++ ignore (GMisc.label ~text:"Dir:" ~packing:(f1#pack ~expand:false) ());
>++ let fileE = GEdit.entry ~packing:f1#add () in
>++ fileE#misc#grab_focus ();
>++ let b = GFile.chooser_button ~action:`SELECT_FOLDER
>++ ~title:"Select a local directory"
>++ ~packing:(f1#pack ~expand:false) () in
>++ ignore (b#connect#selection_changed ~callback:(fun () ->
>++ if not fileE#is_focus then
>++ fileE#set_text (match b#filename with None -> "" | Some s -> s)));
>++ ignore (fileE#connect#changed ~callback:(fun () ->
>++ if fileE#is_focus then ignore (b#set_filename fileE#text)));
>++
>++ let f3 = t#action_area in
>++ let result = ref None in
>++ let contCommand() =
>++ result := Some(fileE#text);
>++ t#destroy () in
>++ let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in
>++ ignore (quitButton#connect#clicked
>++ ~callback:(fun () -> result := None; t#destroy()));
>++ let contButton = GButton.button ~stock:`OK ~packing:f3#add () in
>++ ignore (contButton#connect#clicked ~callback:contCommand);
>++ ignore (fileE#connect#activate ~callback:contCommand);
>++ contButton#grab_default ();
>++ t#show ();
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ GMain.Main.main ();
>++ match !result with None -> None
>++ | Some file ->
>++ Some(Clroot.clroot2string(Clroot.ConnectLocal(Some file)))
>++
>++(* ------ *)
>++
>++let getSecondRoot () =
>++ let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"
>++ ~modal:true ~resizable:true () in
>++ t#misc#grab_focus ();
>++
>++ let message = "Please enter the second directory you want to synchronize." in
>++
>++ let vb = t#vbox in
>++ let hb = GPack.hbox ~packing:(vb#pack ~expand:false ~padding:15) () in
>++ ignore(GMisc.label ~text:message
>++ ~justify:`LEFT
>++ ~packing:(hb#pack ~expand:false ~padding:15) ());
>++ let helpB = GButton.button ~stock:`HELP ~packing:hb#add () in
>++ ignore (helpB#connect#clicked
>++ ~callback:(fun () -> okBox ~parent:t ~title:"Picking roots" ~typ:`INFO
>++ ~message:helpmessage));
>++
>++ let result = ref None in
>++
>++ let f = GPack.vbox ~packing:(vb#pack ~expand:false) () in
>++
>++ let f1 = GPack.hbox ~spacing:4 ~packing:f#add () in
>++ ignore (GMisc.label ~text:"Directory:" ~packing:(f1#pack ~expand:false) ());
>++ let fileE = GEdit.entry ~packing:f1#add () in
>++ fileE#misc#grab_focus ();
>++ let b = GFile.chooser_button ~action:`SELECT_FOLDER
>++ ~title:"Select a local directory"
>++ ~packing:(f1#pack ~expand:false) () in
>++ ignore (b#connect#selection_changed ~callback:(fun () ->
>++ if not fileE#is_focus then
>++ fileE#set_text (match b#filename with None -> "" | Some s -> s)));
>++ ignore (fileE#connect#changed ~callback:(fun () ->
>++ if fileE#is_focus then ignore (b#set_filename fileE#text)));
>++
>++ let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in
>++ let localB = GButton.radio_button ~packing:(f0#pack ~expand:false)
>++ ~label:"Local" () in
>++ let sshB = GButton.radio_button ~group:localB#group
>++ ~packing:(f0#pack ~expand:false)
>++ ~label:"SSH" () in
>++ let rshB = GButton.radio_button ~group:localB#group
>++ ~packing:(f0#pack ~expand:false) ~label:"RSH" () in
>++ let socketB = GButton.radio_button ~group:sshB#group
>++ ~packing:(f0#pack ~expand:false) ~label:"Socket" () in
>++
>++ let f2 = GPack.hbox ~spacing:4 ~packing:f#add () in
>++ ignore (GMisc.label ~text:"Host:" ~packing:(f2#pack ~expand:false) ());
>++ let hostE = GEdit.entry ~packing:f2#add () in
>++
>++ ignore (GMisc.label ~text:"(Optional) User:"
>++ ~packing:(f2#pack ~expand:false) ());
>++ let userE = GEdit.entry ~packing:f2#add () in
>++
>++ ignore (GMisc.label ~text:"Port:"
>++ ~packing:(f2#pack ~expand:false) ());
>++ let portE = GEdit.entry ~packing:f2#add () in
>++
>++ let varLocalRemote = ref (`Local : [`Local|`SSH|`RSH|`SOCKET]) in
>++ let localState() =
>++ varLocalRemote := `Local;
>++ hostE#misc#set_sensitive false;
>++ userE#misc#set_sensitive false;
>++ portE#misc#set_sensitive false;
>++ b#misc#set_sensitive true in
>++ let remoteState() =
>++ hostE#misc#set_sensitive true;
>++ b#misc#set_sensitive false;
>++ match !varLocalRemote with
>++ `SOCKET ->
>++ (portE#misc#set_sensitive true; userE#misc#set_sensitive false)
>++ | _ ->
>++ (portE#misc#set_sensitive false; userE#misc#set_sensitive true) in
>++ let protoState x =
>++ varLocalRemote := x;
>++ remoteState() in
>++ ignore (localB#connect#clicked ~callback:localState);
>++ ignore (sshB#connect#clicked ~callback:(fun () -> protoState(`SSH)));
>++ ignore (rshB#connect#clicked ~callback:(fun () -> protoState(`RSH)));
>++ ignore (socketB#connect#clicked ~callback:(fun () -> protoState(`SOCKET)));
>++ localState();
>++ let getRoot() =
>++ let file = fileE#text in
>++ let user = userE#text in
>++ let host = hostE#text in
>++ let port = portE#text in
>++ match !varLocalRemote with
>++ `Local ->
>++ Clroot.clroot2string(Clroot.ConnectLocal(Some file))
>++ | `SSH | `RSH ->
>++ Clroot.clroot2string(
>++ Clroot.ConnectByShell((if !varLocalRemote=`SSH then "ssh" else "rsh"),
>++ host,
>++ (if user="" then None else Some user),
>++ (if port="" then None else Some port),
>++ Some file))
>++ | `SOCKET ->
>++ Clroot.clroot2string(
>++ (* FIX: report an error if the port entry is not well formed *)
>++ Clroot.ConnectBySocket(host,
>++ portE#text,
>++ Some file)) in
>++ let contCommand() =
>++ try
>++ let root = getRoot() in
>++ result := Some root;
>++ t#destroy ()
>++ with Failure _ ->
>++ if portE#text="" then
>++ okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Please enter a port"
>++ else okBox ~parent:t ~title:"Error" ~typ:`ERROR
>++ ~message:"The port you specify must be an integer"
>++ | _ ->
>++ okBox ~parent:t ~title:"Error" ~typ:`ERROR
>++ ~message:"Something's wrong with the values you entered, try again" in
>++ let f3 = t#action_area in
>++ let quitButton =
>++ GButton.button ~stock:`QUIT ~packing:f3#add () in
>++ ignore (quitButton#connect#clicked ~callback:safeExit);
>++ let contButton =
>++ GButton.button ~stock:`OK ~packing:f3#add () in
>++ ignore (contButton#connect#clicked ~callback:contCommand);
>++ contButton#grab_default ();
>++ ignore (fileE#connect#activate ~callback:contCommand);
>++
>++ t#show ();
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ GMain.Main.main ();
>++ !result
>++
>++(* ------ *)
>++
>++let getPassword rootName msg =
>++ let t =
>++ GWindow.dialog ~parent:(toplevelWindow ())
>++ ~title:"Unison: SSH connection" ~position:`CENTER
>++ ~modal:true ~resizable:false ~border_width:6 () in
>++ t#misc#grab_focus ();
>++
>++ t#vbox#set_spacing 12;
>++
>++ let header =
>++ primaryText
>++ (Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in
>++
>++ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>++ ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG
>++ ~yalign:0. ~packing:h1#pack ());
>++ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>++ ignore(GMisc.label ~markup:(header ^ "\n\n" ^
>++ escapeMarkup (Unicode.protect msg))
>++ ~selectable:true ~yalign:0. ~packing:v1#pack ());
>++
>++ let passwordE = GEdit.entry ~packing:v1#pack ~visibility:false () in
>++ passwordE#misc#grab_focus ();
>++
>++ t#add_button_stock `QUIT `QUIT;
>++ t#add_button_stock `OK `OK;
>++ t#set_default_response `OK;
>++ ignore (passwordE#connect#activate ~callback:(fun _ -> t#response `OK));
>++
>++ t#show();
>++ let res = t#run () in
>++ let pwd = passwordE#text in
>++ t#destroy ();
>++ gtk_sync true;
>++ begin match res with
>++ `DELETE_EVENT | `QUIT -> safeExit (); ""
>++ | `OK -> pwd
>++ end
>++
>++let termInteract = Some getPassword
>++
>++(* ------ *)
>++
>++module React = struct
>++ type 'a t = { mutable state : 'a; mutable observers : ('a -> unit) list }
>++
>++ let make v =
>++ let res = { state = v; observers = [] } in
>++ let update v =
>++ if res.state <> v then begin
>++ res.state <- v; List.iter (fun f -> f v) res.observers
>++ end
>++ in
>++ (res, update)
>++
>++ let const v = fst (make v)
>++
>++ let add_observer x f = x.observers <- f :: x.observers
>++
>++ let state x = x.state
>++
>++ let lift f x =
>++ let (res, update) = make (f (state x)) in
>++ add_observer x (fun v -> update (f v));
>++ res
>++
>++ let lift2 f x y =
>++ let (res, update) = make (f (state x) (state y)) in
>++ add_observer x (fun v -> update (f v (state y)));
>++ add_observer y (fun v -> update (f (state x) v));
>++ res
>++
>++ let lift3 f x y z =
>++ let (res, update) = make (f (state x) (state y) (state z)) in
>++ add_observer x (fun v -> update (f v (state y) (state z)));
>++ add_observer y (fun v -> update (f (state x) v (state z)));
>++ add_observer z (fun v -> update (f (state x) (state y) v));
>++ res
>++
>++ let iter f x = f (state x); add_observer x f
>++
>++ type 'a event = { mutable ev_observers : ('a -> unit) list }
>++
>++ let make_event () =
>++ let res = { ev_observers = [] } in
>++ let trigger v = List.iter (fun f -> f v) res.ev_observers in
>++ (res, trigger)
>++
>++ let add_ev_observer x f = x.ev_observers <- f :: x.ev_observers
>++
>++ let hold v e =
>++ let (res, update) = make v in
>++ add_ev_observer e update;
>++ res
>++
>++ let iter_ev f e = add_ev_observer e f
>++
>++ let lift_ev f e =
>++ let (res, trigger) = make_event () in
>++ add_ev_observer e (fun x -> trigger (f x));
>++ res
>++
>++ module Ops = struct
>++ let (>>) x f = lift f x
>++ let (>|) x f = iter f x
>++
>++ let (>>>) x f = lift_ev f x
>++ let (>>|) x f = iter_ev f x
>++ end
>++end
>++
>++module GtkReact = struct
>++ let entry (e : #GEdit.entry) =
>++ let (res, update) = React.make e#text in
>++ ignore (e#connect#changed ~callback:(fun () -> update (e#text)));
>++ res
>++
>++ let text_combo ((c, _) : _ GEdit.text_combo) =
>++ let (res, update) = React.make c#active in
>++ ignore (c#connect#changed ~callback:(fun () -> update (c#active)));
>++ res
>++
>++ let toggle_button (b : #GButton.toggle_button) =
>++ let (res, update) = React.make b#active in
>++ ignore (b#connect#toggled ~callback:(fun () -> update (b#active)));
>++ res
>++
>++ let file_chooser (c : #GFile.chooser) =
>++ let (res, update) = React.make c#filename in
>++ ignore (c#connect#selection_changed
>++ ~callback:(fun () -> update (c#filename)));
>++ res
>++
>++ let current_tree_view_selection (t : #GTree.view) =
>++ let m =t#model in
>++ Safelist.map (fun p -> m#get_row_reference p) t#selection#get_selected_rows
>++
>++ let tree_view_selection_changed t =
>++ let (res, trigger) = React.make_event () in
>++ ignore (t#selection#connect#changed
>++ ~callback:(fun () -> trigger (current_tree_view_selection t)));
>++ res
>++
>++ let tree_view_selection t =
>++ React.hold (current_tree_view_selection t) (tree_view_selection_changed t)
>++
>++ let label (l : #GMisc.label) x = React.iter (fun v -> l#set_text v) x
>++
>++ let label_underlined (l : #GMisc.label) x =
>++ React.iter (fun v -> l#set_text v; l#set_use_underline true) x
>++
>++ let label_markup (l : #GMisc.label) x =
>++ React.iter (fun v -> l#set_text v; l#set_use_markup true) x
>++
>++ let show w x =
>++ React.iter (fun b -> if b then w#misc#show () else w#misc#hide ()) x
>++ let set_sensitive w x = React.iter (fun b -> w#misc#set_sensitive b) x
>++end
>++
>++open React.Ops
>++
>++(* ------ *)
>++
>++(* Resize an object (typically, a label with line wrapping) so that it
>++ use all its available space *)
>++let adjustSize (w : #GObj.widget) =
>++ let notYet = ref true in
>++ ignore
>++ (w#misc#connect#size_allocate ~callback:(fun r ->
>++ if !notYet then begin
>++ notYet := false;
>++ (* JV: I have no idea where the 12 comes from. Without it,
>++ a window resize may happen. *)
>++ w#misc#set_size_request ~width:(max 10 (r.Gtk.width - 12)) ()
>++ end))
>++
>++let createProfile parent =
>++ let assistant = GAssistant.assistant ~modal:true () in
>++ assistant#set_transient_for parent#as_window;
>++ assistant#set_modal true;
>++ assistant#set_title "Profile Creation";
>++
>++ let nonEmpty s = s <> "" in
>++(*
>++ let integerRe =
>++ Str.regexp "\$[+-]?[0-9]+\\|0o[0-7]+\\|0x[0-9a-zA-Z]+\$" in
>++*)
>++ let integerRe = Str.regexp "[0-9]+" in
>++ let isInteger s =
>++ Str.string_match integerRe s 0 && Str.matched_string s = s in
>++
>++ (* Introduction *)
>++ let intro =
>++ GMisc.label
>++ ~xpad:12 ~ypad:12
>++ ~text:"Welcome to the Unison Profile Creation Assistant.\n\n\
>++ Click \"Next\" to begin."
>++ () in
>++ ignore
>++ (assistant#append_page
>++ ~title:"Profile Creation"
>++ ~page_type:`INTRO
>++ ~complete:true
>++ intro#as_widget);
>++
>++ (* Profile name and description *)
>++ let description = GPack.vbox ~border_width:12 ~spacing:6 () in
>++ adjustSize
>++ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"Please enter the name of the profile and \
>++ possibly a short description."
>++ ~packing:(description#pack ~expand:false) ());
>++ let tbl =
>++ let al = GBin.alignment ~packing:(description#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>++ ~packing:(al#add) () in
>++ let nameEntry =
>++ GEdit.entry ~activates_default:true
>++ ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in
>++ let name = GtkReact.entry nameEntry in
>++ ignore (GMisc.label ~text:"Profile _name:" ~xalign:0.
>++ ~use_underline:true ~mnemonic_widget:nameEntry
>++ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>++ let labelEntry =
>++ GEdit.entry ~activates_default:true
>++ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in
>++ let label = GtkReact.entry labelEntry in
>++ ignore (GMisc.label ~text:"_Description:" ~xalign:0.
>++ ~use_underline:true ~mnemonic_widget:labelEntry
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>++ let existingProfileLabel =
>++ GMisc.label ~xalign:1. ~packing:(description#pack ~expand:false) ()
>++ in
>++ adjustSize existingProfileLabel;
>++ GtkReact.label_markup existingProfileLabel
>++ (name >> fun s -> Format.sprintf " Profile %s already exists."
>++ (escapeMarkup s));
>++ let profileExists =
>++ name >> fun s -> s <> "" && System.file_exists (Prefs.profilePathname s)
>++ in
>++ GtkReact.show existingProfileLabel profileExists;
>++
>++ ignore
>++ (assistant#append_page
>++ ~title:"Profile Description"
>++ ~page_type:`CONTENT
>++ description#as_widget);
>++ let setPageComplete page b = assistant#set_page_complete page#as_widget b in
>++ React.lift2 (&&) (name >> nonEmpty) (profileExists >> not)
>++ >| setPageComplete description;
>++
>++ let connection = GPack.vbox ~border_width:12 ~spacing:18 () in
>++ let al = GBin.alignment ~packing:(connection#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ let vb =
>++ GPack.vbox ~spacing:6 ~packing:(al#add) () in
>++ adjustSize
>++ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"You can use Unison to synchronize a local directory \
>++ with another local directory, or with a remote directory."
>++ ~packing:(vb#pack ~expand:false) ());
>++ adjustSize
>++ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"Please select the kind of synchronization \
>++ you want to perform."
>++ ~packing:(vb#pack ~expand:false) ());
>++ let tbl =
>++ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>++ ~packing:(al#add) () in
>++ ignore (GMisc.label ~text:"Description:" ~xalign:0. ~yalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>++ let kindCombo =
>++ let al =
>++ GBin.alignment ~xscale:0. ~xalign:0.
>++ ~packing:(tbl#attach ~left:1 ~top:0) () in
>++ GEdit.combo_box_text
>++ ~strings:["Local"; "Using SSH"; "Using RSH";
>++ "Through a plain TCP connection"]
>++ ~active:0 ~packing:(al#add) ()
>++ in
>++ ignore (GMisc.label ~text:"Synchronization _kind:" ~xalign:0.
>++ ~use_underline:true ~mnemonic_widget:(fst kindCombo)
>++ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>++ let kind =
>++ GtkReact.text_combo kindCombo
>++ >> fun i -> List.nth [`Local; `SSH; `RSH; `SOCKET] i
>++ in
>++ let isLocal = kind >> fun k -> k = `Local in
>++ let isSSH = kind >> fun k -> k = `SSH in
>++ let isSocket = kind >> fun k -> k = `SOCKET in
>++ let descrLabel =
>++ GMisc.label ~xalign:0. ~line_wrap:true
>++ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>++ in
>++ adjustSize descrLabel;
>++ GtkReact.label descrLabel
>++ (kind >> fun k ->
>++ match k with
>++ `Local ->
>++ "Local synchronization."
>++ | `SSH ->
>++ "This is the recommended way to synchronize \
>++ with a remote machine. A\xc2\xa0remote instance of Unison is \
>++ automatically started via SSH."
>++ | `RSH ->
>++ "Synchronization with a remote machine by starting \
>++ automatically a remote instance of Unison via RSH."
>++ | `SOCKET ->
>++ "Synchronization with a remote machine by connecting \
>++ to an instance of Unison already listening \
>++ on a specific TCP port.");
>++ let vb = GPack.vbox ~spacing:6 ~packing:(connection#add) () in
>++ GtkReact.show vb (isLocal >> not);
>++ ignore (GMisc.label ~markup:"Configuration" ~xalign:0.
>++ ~packing:(vb#pack ~expand:false) ());
>++ let al = GBin.alignment ~packing:(vb#add) () in
>++ al#set_left_padding 12;
>++ let vb = GPack.vbox ~spacing:6 ~packing:(al#add) () in
>++ let requirementLabel =
>++ GMisc.label ~xalign:0. ~line_wrap:true
>++ ~packing:(vb#pack ~expand:false) ()
>++ in
>++ adjustSize requirementLabel;
>++ GtkReact.label requirementLabel
>++ (kind >> fun k ->
>++ match k with
>++ `Local ->
>++ ""
>++ | `SSH ->
>++ "There must be an SSH client installed on this machine, \
>++ and Unison and an SSH server installed on the remote machine."
>++ | `RSH ->
>++ "There must be an RSH client installed on this machine, \
>++ and Unison and an RSH server installed on the remote machine."
>++ | `SOCKET ->
>++ "There must be a Unison server running on the remote machine, \
>++ listening on the port that you specify here. \
>++ (Use \"Unison -socket xxx\" on the remote machine to start \
>++ the Unison server.)");
>++ let connDescLabel =
>++ GMisc.label ~xalign:0. ~line_wrap:true
>++ ~packing:(vb#pack ~expand:false) ()
>++ in
>++ adjustSize connDescLabel;
>++ GtkReact.label connDescLabel
>++ (kind >> fun k ->
>++ match k with
>++ `Local -> ""
>++ | `SSH -> "Please enter the host to connect to and a user name, \
>++ if different from your user name on this machine."
>++ | `RSH -> "Please enter the host to connect to and a user name, \
>++ if different from your user name on this machine."
>++ | `SOCKET -> "Please enter the host and port to connect to.");
>++ let tbl =
>++ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>++ ~packing:(al#add) () in
>++ let hostEntry =
>++ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in
>++ let host = GtkReact.entry hostEntry in
>++ ignore (GMisc.label ~text:"_Host:" ~xalign:0.
>++ ~use_underline:true ~mnemonic_widget:hostEntry
>++ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>++ let userEntry =
>++ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>++ in
>++ GtkReact.show userEntry (isSocket >> not);
>++ let user = GtkReact.entry userEntry in
>++ GtkReact.show
>++ (GMisc.label ~text:"_User:" ~xalign:0. ~yalign:0.
>++ ~use_underline:true ~mnemonic_widget:userEntry
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ())
>++ (isSocket >> not);
>++ let portEntry =
>++ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>++ in
>++ GtkReact.show portEntry isSocket;
>++ let port = GtkReact.entry portEntry in
>++ GtkReact.show
>++ (GMisc.label ~text:"_Port:" ~xalign:0. ~yalign:0.
>++ ~use_underline:true ~mnemonic_widget:portEntry
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ())
>++ isSocket;
>++ let compressLabel =
>++ GMisc.label ~xalign:0. ~line_wrap:true
>++ ~text:"Data compression can greatly improve performance \
>++ on slow connections. However, it may slow down \
>++ things on (fast) local networks."
>++ ~packing:(vb#pack ~expand:false) ()
>++ in
>++ adjustSize compressLabel;
>++ GtkReact.show compressLabel isSSH;
>++ let compressButton =
>++ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ (GButton.check_button ~label:"Enable _compression" ~use_mnemonic:true
>++ ~active:true ~packing:(al#add) ())
>++ in
>++ GtkReact.show compressButton isSSH;
>++ let compress = GtkReact.toggle_button compressButton in
>++(*XXX Disabled for now... *)
>++(*
>++ adjustSize
>++ (GMisc.label ~xalign:0. ~line_wrap:true
>++ ~text:"If this is possible, it is recommended that Unison \
>++ attempts to connect immediately to the remote machine, \
>++ so that it can perform some auto-detections."
>++ ~packing:(vb#pack ~expand:false) ());
>++ let connectImmediately =
>++ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ GtkReact.toggle_button
>++ (GButton.check_button ~label:"Connect _immediately" ~use_mnemonic:true
>++ ~active:true ~packing:(al#add) ())
>++ in
>++ let connectImmediately =
>++ React.lift2 (&&) connectImmediately (isLocal >> not) in
>++*)
>++ let pageComplete =
>++ React.lift2 (||) isLocal
>++ (React.lift2 (&&) (host >> nonEmpty)
>++ (React.lift2 (||) (isSocket >> not) (port >> isInteger)))
>++ in
>++ ignore
>++ (assistant#append_page
>++ ~title:"Connection Setup"
>++ ~page_type:`CONTENT
>++ connection#as_widget);
>++ pageComplete >| setPageComplete connection;
>++
>++ (* Connection to server *)
>++(*XXX Disabled for now... Fill in this page
>++ let connectionInProgress = GMisc.label ~text:"..." () in
>++ let p =
>++ assistant#append_page
>++ ~title:"Connecting to Server..."
>++ ~page_type:`PROGRESS
>++ connectionInProgress#as_widget
>++ in
>++ ignore
>++ (assistant#connect#prepare (fun () ->
>++ if assistant#current_page = p then begin
>++ if React.state connectImmediately then begin
>++ (* XXXX start connection... *)
>++ assistant#set_page_complete connectionInProgress#as_widget true
>++ end else
>++ assistant#set_current_page (p + 1)
>++ end));
>++*)
>++
>++ (* Directory selection *)
>++ let directorySelection = GPack.vbox ~border_width:12 ~spacing:6 () in
>++ adjustSize
>++ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"Please select the two directories that you want to synchronize."
>++ ~packing:(directorySelection#pack ~expand:false) ());
>++ let secondDirLabel1 =
>++ GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"The second directory is relative to your home \
>++ directory on the remote machine."
>++ ~packing:(directorySelection#pack ~expand:false) ()
>++ in
>++ adjustSize secondDirLabel1;
>++ GtkReact.show secondDirLabel1 ((React.lift2 (||) isLocal isSocket) >> not);
>++ let secondDirLabel2 =
>++ GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"The second directory is relative to \
>++ the working directory of the Unison server \
>++ running on the remote machine."
>++ ~packing:(directorySelection#pack ~expand:false) ()
>++ in
>++ adjustSize secondDirLabel2;
>++ GtkReact.show secondDirLabel2 isSocket;
>++ let tbl =
>++ let al =
>++ GBin.alignment ~packing:(directorySelection#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>++ ~packing:(al#add) () in
>++(*XXX Should focus on this button when becomes visible... *)
>++ let firstDirButton =
>++ GFile.chooser_button ~action:`SELECT_FOLDER ~title:"First Directory"
>++ ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) ()
>++ in
>++ isLocal >| (fun b -> firstDirButton#set_title
>++ (if b then "First Directory" else "Local Directory"));
>++ GtkReact.label_underlined
>++ (GMisc.label ~xalign:0.
>++ ~mnemonic_widget:firstDirButton
>++ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ())
>++ (isLocal >> fun b ->
>++ if b then "_First directory:" else "_Local directory:");
>++ let noneToEmpty o = match o with None -> "" | Some s -> s in
>++ let firstDir = GtkReact.file_chooser firstDirButton >> noneToEmpty in
>++ let secondDirButton =
>++ GFile.chooser_button ~action:`SELECT_FOLDER ~title:"Second Directory"
>++ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in
>++ let secondDirLabel =
>++ GMisc.label ~xalign:0.
>++ ~text:"Se_cond directory:"
>++ ~use_underline:true ~mnemonic_widget:secondDirButton
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () in
>++ GtkReact.show secondDirButton isLocal;
>++ GtkReact.show secondDirLabel isLocal;
>++ let remoteDirEdit =
>++ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()
>++ in
>++ let remoteDirLabel =
>++ GMisc.label ~xalign:0.
>++ ~text:"_Remote directory:"
>++ ~use_underline:true ~mnemonic_widget:remoteDirEdit
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()
>++ in
>++ GtkReact.show remoteDirEdit (isLocal >> not);
>++ GtkReact.show remoteDirLabel (isLocal >> not);
>++ let secondDir =
>++ React.lift3 (fun b l r -> if b then l else r) isLocal
>++ (GtkReact.file_chooser secondDirButton >> noneToEmpty)
>++ (GtkReact.entry remoteDirEdit)
>++ in
>++ ignore
>++ (assistant#append_page
>++ ~title:"Directory Selection"
>++ ~page_type:`CONTENT
>++ directorySelection#as_widget);
>++ React.lift2 (||) (isLocal >> not) (React.lift2 (<>) firstDir secondDir)
>++ >| setPageComplete directorySelection;
>++
>++ (* Specific options *)
>++ let options = GPack.vbox ~border_width:18 ~spacing:12 () in
>++ (* Do we need to set specific options for FAT partitions?
>++ If under Windows, then all the options are set properly, except for
>++ ignoreinodenumbers in case one replica is on a FAT partition on a
>++ remote non-Windows machine. As this is unlikely, we do not
>++ handle this case. *)
>++ let fat =
>++ if Util.osType = `Win32 then
>++ React.const false
>++ else begin
>++ let vb =
>++ GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in
>++ let fatLabel =
>++ GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"Select the following option if one of your \
>++ directory is on a FAT partition. This is typically \
>++ the case for a USB stick."
>++ ~packing:(vb#pack ~expand:false) ()
>++ in
>++ adjustSize fatLabel;
>++ let fatButton =
>++ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ (GButton.check_button
>++ ~label:"Synchronization involving a _FAT partition"
>++ ~use_mnemonic:true ~active:false ~packing:(al#add) ())
>++ in
>++ GtkReact.toggle_button fatButton
>++ end
>++ in
>++ (* Fastcheck is safe except on FAT partitions and on Windows when
>++ not in Unicode mode where there is a very slight chance of
>++ missing an update when a file is moved onto another with the same
>++ modification time. Nowadays, FAT is rarely used on working
>++ partitions. In most cases, we should be in Unicode mode.
>++ Thus, it seems sensible to always enable fastcheck. *)
>++(*
>++ let fastcheck = isLocal >> not >> (fun b -> b || Util.osType = `Win32) in
>++*)
>++ (* Unicode mode can be problematic when the source machine is under
>++ Windows and the remote machine is not, as Unison may have already
>++ been used using the legacy Latin 1 encoding. Cygwin also did not
>++ handle Unicode before version 1.7. *)
>++ let vb = GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in
>++ let askUnicode = React.const false in
>++(* isLocal >> not >> fun b -> (b || Util.isCygwin) && Util.osType = `Win32 in*)
>++ GtkReact.show vb askUnicode;
>++ adjustSize
>++ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
>++ ~text:"When synchronizing in case insensitive mode, \
>++ Unison has to make some assumptions regarding \
>++ filename encoding. If ensure, use Unicode."
>++ ~packing:(vb#pack ~expand:false) ());
>++ let vb =
>++ let al = GBin.alignment
>++ ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ GPack.vbox ~spacing:0 ~packing:(al#add) ()
>++ in
>++ ignore
>++ (GMisc.label ~xalign:0. ~text:"Filename encoding:"
>++ ~packing:(vb#pack ~expand:false) ());
>++ let hb =
>++ let al = GBin.alignment
>++ ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ GPack.button_box `VERTICAL ~layout:`START
>++ ~spacing:0 ~packing:(al#add) ()
>++ in
>++ let unicodeButton =
>++ GButton.radio_button ~label:"_Unicode" ~use_mnemonic:true ~active:true
>++ ~packing:(hb#add) ()
>++ in
>++ ignore
>++ (GButton.radio_button ~label:"_Latin 1" ~use_mnemonic:true
>++ ~group:unicodeButton#group ~packing:(hb#add) ());
>++(*
>++ let unicode =
>++ React.lift2 (||) (askUnicode >> not) (GtkReact.toggle_button unicodeButton)
>++ in
>++*)
>++ let p =
>++ assistant#append_page
>++ ~title:"Specific Options" ~complete:true
>++ ~page_type:`CONTENT
>++ options#as_widget
>++ in
>++ ignore
>++ (assistant#connect#prepare ~callback:(fun () ->
>++ if assistant#current_page = p &&
>++ not (Util.osType <> `Win32 || React.state askUnicode)
>++ then
>++ assistant#set_current_page (p + 1)));
>++
>++ let conclusion =
>++ GMisc.label
>++ ~xpad:12 ~ypad:12
>++ ~text:"You have now finished filling in the profile.\n\n\
>++ Click \"Apply\" to create it."
>++ () in
>++ ignore
>++ (assistant#append_page
>++ ~title:"Done" ~complete:true
>++ ~page_type:`CONFIRM
>++ conclusion#as_widget);
>++
>++ let profileName = ref None in
>++ let saveProfile () =
>++ let filename = Prefs.profilePathname (React.state name) in
>++ begin try
>++ let ch =
>++ System.open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename
>++ in
>++ Printf.fprintf ch "# Unison preferences\n";
>++ let label = React.state label in
>++ if label <> "" then Printf.fprintf ch "label = %s\n" label;
>++ Printf.fprintf ch "root = %s\n" (React.state firstDir);
>++ let secondDir = React.state secondDir in
>++ let host = React.state host in
>++ let user = match React.state user with "" -> None | u -> Some u in
>++ let secondRoot =
>++ match React.state kind with
>++ `Local -> Clroot.ConnectLocal (Some secondDir)
>++ | `SSH -> Clroot.ConnectByShell
>++ ("ssh", host, user, None, Some secondDir)
>++ | `RSH -> Clroot.ConnectByShell
>++ ("rsh", host, user, None, Some secondDir)
>++ | `SOCKET -> Clroot.ConnectBySocket
>++ (host, React.state port, Some secondDir)
>++ in
>++ Printf.fprintf ch "root = %s\n" (Clroot.clroot2string secondRoot);
>++ if React.state compress && React.state kind = `SSH then
>++ Printf.fprintf ch "sshargs = -C\n";
>++(*
>++ if React.state fastcheck then
>++ Printf.fprintf ch "fastcheck = true\n";
>++ if React.state unicode then
>++ Printf.fprintf ch "unicode = true\n";
>++*)
>++ if React.state fat then Printf.fprintf ch "fat = true\n";
>++ close_out ch;
>++ profileName := Some (React.state name)
>++ with Sys_error _ as e ->
>++ okBox ~parent:assistant ~typ:`ERROR ~title:"Could not save profile"
>++ ~message:(Uicommon.exn2string e)
>++ end;
>++ assistant#destroy ();
>++ in
>++ ignore (assistant#connect#close ~callback:saveProfile);
>++ ignore (assistant#connect#destroy ~callback:GMain.Main.quit);
>++ ignore (assistant#connect#cancel ~callback:assistant#destroy);
>++ assistant#show ();
>++ GMain.Main.main ();
>++ !profileName
>++
>++(* ------ *)
>++
>++let nameOfType t =
>++ match t with
>++ `BOOL -> "boolean"
>++ | `BOOLDEF -> "boolean"
>++ | `INT -> "integer"
>++ | `STRING -> "text"
>++ | `STRING_LIST -> "text list"
>++ | `CUSTOM -> "custom"
>++ | `UNKNOWN -> "unknown"
>++
>++let defaultValue t =
>++ match t with
>++ `BOOL -> ["true"]
>++ | `BOOLDEF -> ["true"]
>++ | `INT -> ["0"]
>++ | `STRING -> [""]
>++ | `STRING_LIST -> []
>++ | `CUSTOM -> []
>++ | `UNKNOWN -> []
>++
>++let editPreference parent nm ty vl =
>++ let t =
>++ GWindow.dialog ~parent ~border_width:12
>++ ~title:"Edit the Preference"
>++ ~modal:true () in
>++ let vb = t#vbox in
>++ vb#set_spacing 6;
>++
>++ let isList =
>++ match ty with
>++ `STRING_LIST | `CUSTOM | `UNKNOWN -> true
>++ | _ -> false
>++ in
>++ let columns = if isList then 5 else 4 in
>++ let rows = if isList then 3 else 2 in
>++ let tbl =
>++ GPack.table ~rows ~columns ~col_spacings:12 ~row_spacings:6
>++ ~packing:(vb#pack ~expand:false) () in
>++ ignore (GMisc.label ~text:"Preference:" ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>++ ignore (GMisc.label ~text:"Description:" ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>++ ignore (GMisc.label ~text:"Type:" ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:2 ~expand:`NONE) ());
>++ ignore (GMisc.label ~text:(Unicode.protect nm) ~xalign:0. ~selectable:true ()
>++ ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X));
>++ let (doc, _, _) = Prefs.documentation nm in
>++ ignore (GMisc.label ~text:doc ~xalign:0. ~selectable:true ()
>++ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X));
>++ ignore (GMisc.label ~text:(nameOfType ty) ~xalign:0. ~selectable:true ()
>++ ~packing:(tbl#attach ~left:1 ~top:2 ~expand:`X));
>++ let newValue =
>++ if isList then begin
>++ let valueLabel =
>++ GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. ~yalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()
>++ in
>++ let cols = new GTree.column_list in
>++ let c_value = cols#add Gobject.Data.string in
>++ let c_ml = cols#add Gobject.Data.caml in
>++ let lst_store = GTree.list_store cols in
>++ let lst =
>++ let sw =
>++ GBin.scrolled_window ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X)
>++ ~shadow_type:`IN ~height:200 ~width:400
>++ ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>++ GTree.view ~model:lst_store ~headers_visible:false
>++ ~reorderable:true ~packing:sw#add () in
>++ valueLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>++ let column =
>++ GTree.view_column
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) ()
>++ in
>++ ignore (lst#append_column column);
>++ let vb =
>++ GPack.button_box
>++ `VERTICAL ~layout:`START ~spacing:6
>++ ~packing:(tbl#attach ~left:2 ~top:3 ~expand:`NONE) ()
>++ in
>++ let selection = GtkReact.tree_view_selection lst in
>++ let hasSel = selection >> fun l -> l <> [] in
>++ let addB =
>++ GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in
>++ let removeB =
>++ GButton.button ~stock:`REMOVE ~packing:(vb#pack ~expand:false) () in
>++ let editB =
>++ GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in
>++ let upB =
>++ GButton.button ~stock:`GO_UP ~packing:(vb#pack ~expand:false) () in
>++ let downB =
>++ GButton.button ~stock:`GO_DOWN ~packing:(vb#pack ~expand:false) () in
>++ List.iter (fun b -> b#set_xalign 0.) [addB; removeB; editB; upB; downB];
>++ GtkReact.set_sensitive removeB hasSel;
>++ let editLabel =
>++ GMisc.label ~text:"Edited _item:"
>++ ~use_underline:true ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:4 ~expand:`NONE) ()
>++ in
>++ let editEntry =
>++ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:4 ~expand:`X) () in
>++ editLabel#set_mnemonic_widget (Some (editEntry :> GObj.widget));
>++ let edit = GtkReact.entry editEntry in
>++ let edited =
>++ React.lift2
>++ (fun l txt ->
>++ match l with
>++ [rf] -> lst_store#get ~row:rf#iter ~column:c_ml <> txt
>++ | _ -> false)
>++ selection edit
>++ in
>++ GtkReact.set_sensitive editB edited;
>++ let selectionChange = GtkReact.tree_view_selection_changed lst in
>++ selectionChange >>| (fun s ->
>++ match s with
>++ [rf] -> editEntry#set_text
>++ (lst_store#get ~row:rf#iter ~column:c_value)
>++ | _ -> ());
>++ let add () =
>++ let txt = editEntry#text in
>++ let row = lst_store#append () in
>++ lst_store#set ~row ~column:c_value txt;
>++ lst_store#set ~row ~column:c_ml txt;
>++ lst#selection#select_iter row;
>++ lst#scroll_to_cell (lst_store#get_path row) column
>++ in
>++ ignore (addB#connect#clicked ~callback:add);
>++ ignore (editEntry#connect#activate ~callback:add);
>++ let remove () =
>++ match React.state selection with
>++ [rf] -> let i = rf#iter in
>++ if lst_store#iter_next i then
>++ lst#selection#select_iter i
>++ else begin
>++ let p = rf#path in
>++ if GTree.Path.prev p then
>++ lst#selection#select_path p
>++ end;
>++ ignore (lst_store#remove rf#iter)
>++ | _ -> ()
>++ in
>++ ignore (removeB#connect#clicked ~callback:remove);
>++ let edit () =
>++ match React.state selection with
>++ [rf] -> let row = rf#iter in
>++ let txt = editEntry#text in
>++ lst_store#set ~row ~column:c_value txt;
>++ lst_store#set ~row ~column:c_ml txt
>++ | _ -> ()
>++ in
>++ ignore (editB#connect#clicked ~callback:edit);
>++ let updateUpDown l =
>++ let (upS, downS) =
>++ match l with
>++ [rf] -> (GTree.Path.prev rf#path, lst_store#iter_next rf#iter)
>++ | _ -> (false, false)
>++ in
>++ upB#misc#set_sensitive upS;
>++ downB#misc#set_sensitive downS
>++ in
>++ selectionChange >>| updateUpDown;
>++ ignore (lst_store#connect#after#row_deleted
>++ ~callback:(fun _ -> updateUpDown (React.state selection)));
>++ let go_up () =
>++ match React.state selection with
>++ [rf] -> let p = rf#path in
>++ if GTree.Path.prev p then begin
>++ let i = rf#iter in
>++ let i' = lst_store#get_iter p in
>++ ignore (lst_store#swap i i');
>++ lst#scroll_to_cell (lst_store#get_path i) column
>++ end;
>++ updateUpDown (React.state selection)
>++ | _ -> ()
>++ in
>++ ignore (upB#connect#clicked ~callback:go_up);
>++ let go_down () =
>++ match React.state selection with
>++ [rf] -> let i = rf#iter in
>++ if lst_store#iter_next i then begin
>++ let i' = rf#iter in
>++ ignore (lst_store#swap i i');
>++ lst#scroll_to_cell (lst_store#get_path i') column
>++ end;
>++ updateUpDown (React.state selection)
>++ | _ -> ()
>++ in
>++ ignore (downB#connect#clicked ~callback:go_down);
>++ List.iter
>++ (fun v ->
>++ let row = lst_store#append () in
>++ lst_store#set ~row ~column:c_value (Unicode.protect v);
>++ lst_store#set ~row ~column:c_ml v)
>++ vl;
>++ (fun () ->
>++ let l = ref [] in
>++ lst_store#foreach
>++ (fun _ row -> l := lst_store#get ~row ~column:c_ml :: !l; false);
>++ List.rev !l)
>++ end else begin
>++ let v = List.hd vl in
>++ begin match ty with
>++ `BOOL | `BOOLDEF ->
>++ let hb =
>++ GPack.button_box `HORIZONTAL ~layout:`START
>++ ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) ()
>++ in
>++ let isTrue = v = "true" || v = "yes" in
>++ let trueB =
>++ GButton.radio_button ~label:"_True" ~use_mnemonic:true
>++ ~active:isTrue ~packing:(hb#add) ()
>++ in
>++ ignore
>++ (GButton.radio_button ~label:"_False" ~use_mnemonic:true
>++ ~group:trueB#group ~active:(not isTrue) ~packing:(hb#add) ());
>++ ignore
>++ (GMisc.label ~text:"Value:" ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ());
>++ (fun () -> [if trueB#active then "true" else "false"])
>++ | `INT | `STRING ->
>++ let valueEntry =
>++ GEdit.entry ~text:v ~width_chars: 40
>++ ~activates_default:true
>++ ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) ()
>++ in
>++ ignore
>++ (GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0.
>++ ~mnemonic_widget:valueEntry
>++ ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ());
>++ (fun () -> [valueEntry#text])
>++ | `STRING_LIST | `CUSTOM | `UNKNOWN ->
>++ assert false
>++ end
>++ end
>++ in
>++
>++ let res = ref None in
>++ let cancelCommand () = t#destroy () in
>++ let cancelButton =
>++ GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in
>++ ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>++ let okCommand _ = res := Some (newValue ()); t#destroy () in
>++ let okButton =
>++ GButton.button ~stock:`OK ~packing:t#action_area#add () in
>++ ignore (okButton#connect#clicked ~callback:okCommand);
>++ okButton#grab_default ();
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ t#show ();
>++ GMain.Main.main ();
>++ !res
>++
>++
>++let markupRe = Str.regexp "<\$[a-z]+\$>\\|</\$[a-z]+\$>\\|&\$[a-z]+\$;"
>++let entities =
>++ [("amp", "&"); ("lt", "<"); ("gt", ">"); ("quot", "\""); ("apos", "'")]
>++
>++let rec insertMarkupRec tags (t : #GText.view) s i tl =
>++ try
>++ let j = Str.search_forward markupRe s i in
>++ if j > i then
>++ t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i));
>++ let tag = try Some (Str.matched_group 1 s) with Not_found -> None in
>++ match tag with
>++ Some tag ->
>++ insertMarkupRec tags t s (Str.group_end 0)
>++ ((try [List.assoc tag tags] with Not_found -> []) :: tl)
>++ | None ->
>++ let entity = try Some (Str.matched_group 3 s) with Not_found -> None in
>++ match entity with
>++ None ->
>++ insertMarkupRec tags t s (Str.group_end 0) (List.tl tl)
>++ | Some ent ->
>++ begin try
>++ t#buffer#insert ~tags:(List.flatten tl) (List.assoc ent entities)
>++ with Not_found -> () end;
>++ insertMarkupRec tags t s (Str.group_end 0) tl
>++ with Not_found ->
>++ let j = String.length s in
>++ if j > i then
>++ t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i))
>++
>++let insertMarkup tags t s =
>++ t#buffer#set_text ""; insertMarkupRec tags t s 0 []
>++
>++let documentPreference ~compact ~packing =
>++ let vb = GPack.vbox ~spacing:6 ~packing () in
>++ ignore (GMisc.label ~markup:"Documentation" ~xalign:0.
>++ ~packing:(vb#pack ~expand:false) ());
>++ let al = GBin.alignment ~packing:(vb#pack ~expand:true ~fill:true) () in
>++ al#set_left_padding 12;
>++ let columns = if compact then 3 else 2 in
>++ let tbl =
>++ GPack.table ~rows:2 ~columns ~col_spacings:12 ~row_spacings:6
>++ ~packing:(al#add) () in
>++ tbl#misc#set_sensitive false;
>++ ignore (GMisc.label ~text:"Short description:" ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>++ ignore (GMisc.label ~text:"Long description:" ~xalign:0. ~yalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>++ let shortDescr =
>++ GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)
>++ ~xalign:0. ~selectable:true () in
>++ let longDescr =
>++ let sw =
>++ if compact then
>++ GBin.scrolled_window ~height:128 ~width:640
>++ ~packing:(tbl#attach ~left:0 ~top:2 ~right:2 ~expand:`BOTH)
>++ ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
>++ else
>++ GBin.scrolled_window ~height:128 ~width:640
>++ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`BOTH)
>++ ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
>++ in
>++ GText.view ~editable:false ~packing:sw#add ~wrap_mode:`WORD ()
>++ in
>++ let (>>>) x f = f x in
>++ let newlineRe = Str.regexp "\n *" in
>++ let styleRe = Str.regexp "{\\\\\$[a-z]+\$ \$[^{}]*\$}" in
>++ let verbRe = Str.regexp "\\\\verb|\$[^|]*\$|" in
>++ let argRe = Str.regexp "\\\\ARG{\$[^{}]*\$}" in
>++ let textttRe = Str.regexp "\\\\texttt{\$[^{}]*\$}" in
>++ let emphRe = Str.regexp "\\\\emph{\$[^{}]*\$}" in
>++ let sectionRe = Str.regexp "\\\\sectionref{\$[^{}]*\$}{\$[^{}]*\$}" in
>++ let emdash = Str.regexp_string "---" in
>++ let parRe = Str.regexp "\\\\par *" in
>++ let underRe = Str.regexp "\\\\_ *" in
>++ let dollarRe = Str.regexp "\\\\\\$ *" in
>++ let formatDoc doc =
>++ doc >>>
>++ Str.global_replace newlineRe " " >>>
>++ escapeMarkup >>>
>++ Str.global_substitute styleRe
>++ (fun s ->
>++ try
>++ let tag =
>++ match Str.matched_group 1 s with
>++ "em" -> "i"
>++ | "tt" -> "tt"
>++ | _ -> raise Exit
>++ in
>++ Format.sprintf "<%s>%s</%s>" tag (Str.matched_group 2 s) tag
>++ with Exit ->
>++ Str.matched_group 0 s) >>>
>++ Str.global_replace verbRe "<tt>\\1</tt>" >>>
>++ Str.global_replace argRe "<tt>\\1</tt>" >>>
>++ Str.global_replace textttRe "<tt>\\1</tt>" >>>
>++ Str.global_replace emphRe "\\1" >>>
>++ Str.global_replace sectionRe "Section '\\2'" >>>
>++ Str.global_replace emdash "\xe2\x80\x94" >>>
>++ Str.global_replace parRe "\n" >>>
>++ Str.global_replace underRe "_" >>>
>++ Str.global_replace dollarRe "_"
>++ in
>++ let tags =
>++ let create = longDescr#buffer#create_tag in
>++ [("i", create [`FONT_DESC (Lazy.force fontItalic)]);
>++ ("tt", create [`FONT_DESC (Lazy.force fontMonospace)])]
>++ in
>++ fun nm ->
>++ let (short, long, _) =
>++ match nm with
>++ Some nm ->
>++ tbl#misc#set_sensitive true;
>++ Prefs.documentation nm
>++ | _ ->
>++ tbl#misc#set_sensitive false;
>++ ("", "", false)
>++ in
>++ shortDescr#set_text (String.capitalize_ascii short);
>++ insertMarkup tags longDescr (formatDoc long)
>++(* longDescr#buffer#set_text (formatDoc long)*)
>++
>++let addPreference parent =
>++ let t =
>++ GWindow.dialog ~parent ~border_width:12
>++ ~title:"Add a Preference"
>++ ~modal:true () in
>++ let vb = t#vbox in
>++(* vb#set_spacing 18;*)
>++ let paned = GPack.paned `VERTICAL ~packing:vb#add () in
>++
>++ let lvb = GPack.vbox ~spacing:6 ~packing:paned#pack1 () in
>++ let preferenceLabel =
>++ GMisc.label
>++ ~text:"_Preferences:" ~use_underline:true
>++ ~xalign:0. ~packing:(lvb#pack ~expand:false) ()
>++ in
>++ let cols = new GTree.column_list in
>++ let c_name = cols#add Gobject.Data.string in
>++ let basic_store = GTree.list_store cols in
>++ let full_store = GTree.list_store cols in
>++ let lst =
>++ let sw =
>++ GBin.scrolled_window ~packing:(lvb#pack ~expand:true)
>++ ~shadow_type:`IN ~height:200 ~width:400
>++ ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>++ GTree.view ~headers_visible:false ~packing:sw#add () in
>++ preferenceLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>++ ignore (lst#append_column
>++ (GTree.view_column
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) ()));
>++ let hiddenPrefs =
>++ ["auto"; "doc"; "silent"; "terse"; "testserver"; "version"] in
>++ let shownPrefs =
>++ ["label"; "key"] in
>++ let insert (store : #GTree.list_store) all =
>++ List.iter
>++ (fun nm ->
>++ if
>++ all || List.mem nm shownPrefs ||
>++ (let (_, _, basic) = Prefs.documentation nm in basic &&
>++ not (List.mem nm hiddenPrefs))
>++ then begin
>++ let row = store#append () in
>++ store#set ~row ~column:c_name nm
>++ end)
>++ (Prefs.list ())
>++ in
>++ insert basic_store false;
>++ insert full_store true;
>++
>++ let showAll =
>++ GtkReact.toggle_button
>++ (GButton.check_button ~label:"_Show all preferences"
>++ ~use_mnemonic:true ~active:false ~packing:(lvb#pack ~expand:false) ())
>++ in
>++ showAll >|
>++ (fun b ->
>++ lst#set_model
>++ (Some (if b then full_store else basic_store :> GTree.model)));
>++
>++ let selection = GtkReact.tree_view_selection lst in
>++ let updateDoc = documentPreference ~compact:true ~packing:paned#pack2 in
>++ selection >|
>++ (fun l ->
>++ let nm =
>++ match l with
>++ [rf] ->
>++ let row = rf#iter in
>++ let store =
>++ if React.state showAll then full_store else basic_store in
>++ Some (store#get ~row ~column:c_name)
>++ | _ ->
>++ None
>++ in
>++ updateDoc nm);
>++
>++ let cancelCommand () = t#destroy () in
>++ let cancelButton =
>++ GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in
>++ ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>++ ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true));
>++ let ok = ref false in
>++ let addCommand _ = ok := true; t#destroy () in
>++ let addButton =
>++ GButton.button ~stock:`ADD ~packing:t#action_area#add () in
>++ ignore (addButton#connect#clicked ~callback:addCommand);
>++ GtkReact.set_sensitive addButton (selection >> fun l -> l <> []);
>++ ignore (lst#connect#row_activated ~callback:(fun _ _ -> addCommand ()));
>++ addButton#grab_default ();
>++
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ t#show ();
>++ GMain.Main.main ();
>++ if not !ok then None else
>++ match React.state selection with
>++ [rf] ->
>++ let row = rf#iter in
>++ let store =
>++ if React.state showAll then full_store else basic_store in
>++ Some (store#get ~row ~column:c_name)
>++ | _ ->
>++ None
>++
>++let editProfile parent name =
>++ let t =
>++ GWindow.dialog ~parent ~border_width:12
>++ ~title:(Format.sprintf "%s - Profile Editor" name)
>++ ~modal:true () in
>++ let vb = t#vbox in
>++(* t#vbox#set_spacing 18;*)
>++ let paned = GPack.paned `VERTICAL ~packing:vb#add () in
>++
>++ let lvb = GPack.vbox ~spacing:6 ~packing:paned#pack1 () in
>++ let preferenceLabel =
>++ GMisc.label
>++ ~text:"_Preferences:" ~use_underline:true
>++ ~xalign:0. ~packing:(lvb#pack ~expand:false) ()
>++ in
>++ let hb = GPack.hbox ~spacing:12 ~packing:(lvb#add) () in
>++ let cols = new GTree.column_list in
>++ let c_name = cols#add Gobject.Data.string in
>++ let c_type = cols#add Gobject.Data.string in
>++ let c_value = cols#add Gobject.Data.string in
>++ let c_ml = cols#add Gobject.Data.caml in
>++ let lst_store = GTree.list_store cols in
>++ let lst_sorted_store = GTree.model_sort lst_store in
>++ lst_sorted_store#set_sort_column_id 0 `ASCENDING;
>++ let lst =
>++ let sw =
>++ GBin.scrolled_window ~packing:(hb#pack ~expand:true)
>++ ~shadow_type:`IN ~height:300 ~width:600
>++ ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>++ GTree.view ~model:lst_sorted_store ~packing:sw#add
>++ ~headers_clickable:true () in
>++ preferenceLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>++ let vc_name =
>++ GTree.view_column
>++ ~title:"Name"
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) () in
>++ vc_name#set_sort_column_id 0;
>++ ignore (lst#append_column vc_name);
>++ ignore (lst#append_column
>++ (GTree.view_column
>++ ~title:"Type"
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_type]) ()));
>++ ignore (lst#append_column
>++ (GTree.view_column
>++ ~title:"Value"
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) ()));
>++ let vb =
>++ GPack.button_box
>++ `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) ()
>++ in
>++ let selection = GtkReact.tree_view_selection lst in
>++ let hasSel = selection >> fun l -> l <> [] in
>++ let addB =
>++ GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in
>++ let editB =
>++ GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in
>++ let deleteB =
>++ GButton.button ~stock:`DELETE ~packing:(vb#pack ~expand:false) () in
>++ List.iter (fun b -> b#set_xalign 0.) [addB; editB; deleteB];
>++ GtkReact.set_sensitive editB hasSel;
>++ GtkReact.set_sensitive deleteB hasSel;
>++
>++ let (modified, setModified) = React.make false in
>++ let formatValue vl = Unicode.protect (String.concat ", " vl) in
>++ let deletePref () =
>++ match React.state selection with
>++ [rf] ->
>++ let row = lst_sorted_store#convert_iter_to_child_iter rf#iter in
>++ let (nm, ty, vl) = lst_store#get ~row ~column:c_ml in
>++ if
>++ twoBox ~kind:`DIALOG_QUESTION ~parent:t ~title:"Preference Deletion"
>++ ~bstock:`CANCEL ~astock:`DELETE
>++ (Format.sprintf "Do you really want to delete preference %s?"
>++ (Unicode.protect nm))
>++ then begin
>++ ignore (lst_store#remove row);
>++ setModified true
>++ end
>++ | _ ->
>++ ()
>++ in
>++ let editPref path =
>++ let row =
>++ lst_sorted_store#convert_iter_to_child_iter
>++ (lst_sorted_store#get_iter path) in
>++ let (nm, ty, vl) = lst_store#get ~row ~column:c_ml in
>++ match editPreference t nm ty vl with
>++ Some [] ->
>++ deletePref ()
>++ | Some vl' when vl <> vl' ->
>++ lst_store#set ~row ~column:c_ml (nm, ty, vl');
>++ lst_store#set ~row ~column:c_value (formatValue vl');
>++ setModified true
>++ | _ ->
>++ ()
>++ in
>++ let add () =
>++ match addPreference t with
>++ None ->
>++ ()
>++ | Some nm ->
>++ let existing = ref false in
>++ lst_store#foreach
>++ (fun path row ->
>++ let (nm', _, _) = lst_store#get ~row ~column:c_ml in
>++ if nm = nm' then begin
>++ existing := true; editPref path; true
>++ end else
>++ false);
>++ if not !existing then begin
>++ let ty = Prefs.typ nm in
>++ match editPreference parent nm ty (defaultValue ty) with
>++ Some vl when vl <> [] ->
>++ let row = lst_store#append () in
>++ lst_store#set ~row ~column:c_name (Unicode.protect nm);
>++ lst_store#set ~row ~column:c_type (nameOfType ty);
>++ lst_store#set ~row ~column:c_ml (nm, ty, vl);
>++ lst_store#set ~row ~column:c_value (formatValue vl);
>++ setModified true
>++ | _ ->
>++ ()
>++ end
>++ in
>++ ignore (addB#connect#clicked ~callback:add);
>++ ignore (editB#connect#clicked
>++ ~callback:(fun () ->
>++ match React.state selection with
>++ [p] -> editPref p#path
>++ | _ -> ()));
>++ ignore (deleteB#connect#clicked ~callback:deletePref);
>++
>++ let updateDoc = documentPreference ~compact:true ~packing:paned#pack2 in
>++ selection >|
>++ (fun l ->
>++ let nm =
>++ match l with
>++ [rf] ->
>++ let row = rf#iter in
>++ Some (lst_sorted_store#get ~row ~column:c_name)
>++ | _ ->
>++ None
>++ in
>++ updateDoc nm);
>++ ignore (lst#connect#row_activated ~callback:(fun path _ -> editPref path));
>++
>++ let group l =
>++ let rec groupRec l k vl l' =
>++ match l with
>++ (k', v) :: r ->
>++ if k = k' then
>++ groupRec r k (v :: vl) l'
>++ else
>++ groupRec r k' [v] ((k, vl) :: l')
>++ | [] ->
>++ Safelist.fold_left
>++ (fun acc (k, l) -> (k, List.rev l) :: acc) [] ((k, vl) :: l')
>++ in
>++ match l with
>++ (k, v) :: r -> groupRec r k [v] []
>++ | [] -> []
>++ in
>++ let lastOne l = [List.hd (Safelist.rev l)] in
>++ let normalizeValue t vl =
>++ match t with
>++ `BOOL | `INT | `STRING -> lastOne vl
>++ | `STRING_LIST | `CUSTOM | `UNKNOWN -> vl
>++ | `BOOLDEF ->
>++ let l = lastOne vl in
>++ if l = ["default"] || l = ["auto"] then [] else l
>++ in
>++ let (>>>) x f = f x in
>++ Prefs.readAFile name
>++ >>> List.map (fun (_, _, nm, v) -> Prefs.canonicalName nm, v)
>++ >>> List.stable_sort (fun (nm, _) (nm', _) -> compare nm nm')
>++ >>> group
>++ >>> List.iter
>++ (fun (nm, vl) ->
>++ let nm = Prefs.canonicalName nm in
>++ let ty = Prefs.typ nm in
>++ let vl = normalizeValue ty vl in
>++ if vl <> [] then begin
>++ let row = lst_store#append () in
>++ lst_store#set ~row ~column:c_name (Unicode.protect nm);
>++ lst_store#set ~row ~column:c_type (nameOfType ty);
>++ lst_store#set ~row ~column:c_value (formatValue vl);
>++ lst_store#set ~row ~column:c_ml (nm, ty, vl)
>++ end);
>++
>++ let applyCommand _ =
>++ if React.state modified then begin
>++ let filename = Prefs.profilePathname name in
>++ try
>++ let ch =
>++ System.open_out_gen [Open_wronly; Open_creat; Open_trunc] 0o600
>++ filename
>++ in
>++ (*XXX Should trim whitespaces and check for '\n' at some point *)
>++ Printf.fprintf ch "# Unison preferences\n";
>++ lst_store#foreach
>++ (fun path row ->
>++ let (nm, _, vl) = lst_store#get ~row ~column:c_ml in
>++ List.iter (fun v -> Printf.fprintf ch "%s = %s\n" nm v) vl;
>++ false);
>++ close_out ch;
>++ setModified false
>++ with Sys_error _ as e ->
>++ okBox ~parent:t ~typ:`ERROR ~title:"Could not save profile"
>++ ~message:(Uicommon.exn2string e)
>++ end
>++ in
>++ let applyButton =
>++ GButton.button ~stock:`APPLY ~packing:t#action_area#add () in
>++ ignore (applyButton#connect#clicked ~callback:applyCommand);
>++ GtkReact.set_sensitive applyButton modified;
>++ let cancelCommand () = t#destroy () in
>++ let cancelButton =
>++ GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in
>++ ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>++ ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true));
>++ let okCommand _ = applyCommand (); t#destroy () in
>++ let okButton =
>++ GButton.button ~stock:`OK ~packing:t#action_area#add () in
>++ ignore (okButton#connect#clicked ~callback:okCommand);
>++ okButton#grab_default ();
>++(*
>++List.iter
>++ (fun (nm, _, long) ->
>++ try
>++ let long = formatDoc long in
>++ ignore (Str.search_forward (Str.regexp_string "\\") long 0);
>++ Format.eprintf "%s %s@." nm long
>++ with Not_found -> ())
>++(Prefs.listVisiblePrefs ());
>++*)
>++
>++(*
>++TODO:
>++ - Extra tabs for common preferences
>++ (should keep track of any change, or blacklist some preferences)
>++ - Add, modify, delete
>++ - Keep track of whether there is any change (apply button)
>++*)
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ t#show ();
>++ GMain.Main.main ()
>++
>++(* ------ *)
>++
>++let getProfile quit =
>++ let ok = ref false in
>++
>++ (* Build the dialog *)
>++ let t =
>++ GWindow.dialog ~parent:(toplevelWindow ()) ~border_width:12
>++ ~title:"Profile Selection"
>++ ~modal:true () in
>++ t#set_default_width 550;
>++
>++ let cancelCommand _ = t#destroy () in
>++ let cancelButton =
>++ GButton.button ~stock:(if quit then `QUIT else `CANCEL)
>++ ~packing:t#action_area#add () in
>++ ignore (cancelButton#connect#clicked ~callback:cancelCommand);
>++ ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true));
>++ cancelButton#misc#set_can_default true;
>++
>++ let okCommand() = ok := true; t#destroy () in
>++ let okButton =
>++ GButton.button ~stock:`OPEN ~packing:t#action_area#add () in
>++ ignore (okButton#connect#clicked ~callback:okCommand);
>++ okButton#misc#set_sensitive false;
>++ okButton#grab_default ();
>++
>++ let vb = t#vbox in
>++ t#vbox#set_spacing 18;
>++
>++ let al = GBin.alignment ~packing:(vb#add) () in
>++ al#set_left_padding 12;
>++
>++ let lvb = GPack.vbox ~spacing:6 ~packing:(al#add) () in
>++ let selectLabel =
>++ GMisc.label
>++ ~text:"Select a _profile:" ~use_underline:true
>++ ~xalign:0. ~packing:(lvb#pack ~expand:false) ()
>++ in
>++ let hb = GPack.hbox ~spacing:12 ~packing:(lvb#add) () in
>++ let sw =
>++ GBin.scrolled_window ~packing:(hb#pack ~expand:true) ~height:300
>++ ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
>++ let cols = new GTree.column_list in
>++ let c_name = cols#add Gobject.Data.string in
>++ let c_label = cols#add Gobject.Data.string in
>++ let c_ml = cols#add Gobject.Data.caml in
>++ let lst_store = GTree.list_store cols in
>++ let lst = GTree.view ~model:lst_store ~packing:sw#add () in
>++ selectLabel#set_mnemonic_widget (Some (lst :> GObj.widget));
>++ let vc_name =
>++ GTree.view_column
>++ ~title:"Profile"
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) ()
>++ in
>++ ignore (lst#append_column vc_name);
>++ ignore (lst#append_column
>++ (GTree.view_column
>++ ~title:"Description"
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_label]) ()));
>++
>++ let vb = GPack.vbox ~spacing:6 ~packing:(vb#pack ~expand:false) () in
>++ ignore (GMisc.label ~markup:"Summary" ~xalign:0.
>++ ~packing:(vb#pack ~expand:false) ());
>++ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in
>++ al#set_left_padding 12;
>++ let tbl =
>++ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6
>++ ~packing:(al#add) () in
>++ tbl#misc#set_sensitive false;
>++ ignore (GMisc.label ~text:"First root:" ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
>++ ignore (GMisc.label ~text:"Second root:" ~xalign:0.
>++ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
>++ let root1 =
>++ GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)
>++ ~xalign:0. ~selectable:true () in
>++ let root2 =
>++ GMisc.label ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X)
>++ ~xalign:0. ~selectable:true () in
>++
>++ let fillLst default =
>++ Uicommon.scanProfiles();
>++ lst_store#clear ();
>++ Safelist.iter
>++ (fun (profile, info) ->
>++ let labeltext =
>++ match info.Uicommon.label with None -> "" | Some l -> l in
>++ let row = lst_store#append () in
>++ lst_store#set ~row ~column:c_name (Unicode.protect profile);
>++ lst_store#set ~row ~column:c_label (Unicode.protect labeltext);
>++ lst_store#set ~row ~column:c_ml (profile, info);
>++ if Some profile = default then begin
>++ lst#selection#select_iter row;
>++ lst#scroll_to_cell (lst_store#get_path row) vc_name
>++ end)
>++ (Safelist.sort (fun (p, _) (p', _) -> compare p p') !Uicommon.profilesAndRoots)
>++ in
>++ let selection = GtkReact.tree_view_selection lst in
>++ let hasSel = selection >> fun l -> l <> [] in
>++ let selInfo =
>++ selection >> fun l ->
>++ match l with
>++ [rf] -> Some (lst_store#get ~row:rf#iter ~column:c_ml, rf)
>++ | _ -> None
>++ in
>++ selInfo >|
>++ (fun info ->
>++ match info with
>++ Some ((profile, info), _) ->
>++ begin match info.Uicommon.roots with
>++ [r1; r2] -> root1#set_text (Unicode.protect r1);
>++ root2#set_text (Unicode.protect r2);
>++ tbl#misc#set_sensitive true
>++ | _ -> root1#set_text ""; root2#set_text "";
>++ tbl#misc#set_sensitive false
>++ end
>++ | None ->
>++ root1#set_text ""; root2#set_text "";
>++ tbl#misc#set_sensitive false);
>++ GtkReact.set_sensitive okButton hasSel;
>++
>++ let vb =
>++ GPack.button_box
>++ `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) ()
>++ in
>++ let addButton =
>++ GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in
>++ ignore (addButton#connect#clicked
>++ ~callback:(fun () ->
>++ match createProfile t with
>++ Some p -> fillLst (Some p) | None -> ()));
>++ let editButton =
>++ GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in
>++ ignore (editButton#connect#clicked
>++ ~callback:(fun () -> match React.state selInfo with
>++ None ->
>++ ()
>++ | Some ((p, _), _) ->
>++ editProfile t p; fillLst (Some p)));
>++ GtkReact.set_sensitive editButton hasSel;
>++ let deleteProfile () =
>++ match React.state selInfo with
>++ Some ((profile, _), rf) ->
>++ if
>++ twoBox ~kind:`DIALOG_QUESTION ~parent:t ~title:"Profile Deletion"
>++ ~bstock:`CANCEL ~astock:`DELETE
>++ (Format.sprintf "Do you really want to delete profile %s?"
>++ (transcode profile))
>++ then begin
>++ try
>++ System.unlink (Prefs.profilePathname profile);
>++ ignore (lst_store#remove rf#iter)
>++ with Unix.Unix_error _ -> ()
>++ end
>++ | None ->
>++ ()
>++ in
>++ let deleteButton =
>++ GButton.button ~stock:`DELETE ~packing:(vb#pack ~expand:false) () in
>++ ignore (deleteButton#connect#clicked ~callback:deleteProfile);
>++ GtkReact.set_sensitive deleteButton hasSel;
>++ List.iter (fun b -> b#set_xalign 0.) [addButton; editButton; deleteButton];
>++
>++ ignore (lst#connect#row_activated ~callback:(fun _ _ -> okCommand ()));
>++ fillLst None;
>++ lst#misc#grab_focus ();
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ t#show ();
>++ GMain.Main.main ();
>++ match React.state selInfo with
>++ Some ((p, _), _) when !ok -> Some p
>++ | _ -> None
>++
>++(* ------ *)
>++
>++let documentation sect =
>++ let title = "Documentation" in
>++ let t = GWindow.dialog ~title () in
>++ let t_dismiss =
>++ GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
>++ t_dismiss#grab_default ();
>++ let dismiss () = t#destroy () in
>++ ignore (t_dismiss#connect#clicked ~callback:dismiss);
>++ ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));
>++
>++ let (name, docstr) = Safelist.assoc sect Strings.docs in
>++ let hb = GPack.hbox ~packing:(t#vbox#pack ~expand:false ~padding:2) () in
>++
>++ let t_text =
>++ new scrolled_text ~editable:false
>++ ~width:80 ~height:20 ~packing:(t#vbox#pack ~expand:true) ()
>++ in
>++ t_text#insert docstr;
>++
>++ let menuBar =
>++ GMenu.menu_bar ~border_width:0
>++ ~packing:(hb#pack ~expand:true ~fill:false) () in
>++ let mi = GMenu.menu_item ~label:"Topics" () in
>++ menuBar#insert mi 0;
>++
>++ let sect_idx = ref 0 in
>++ let idx = ref 0 in
>++ let menu = GMenu.menu ~packing:(mi#set_submenu) () in
>++ let addDocSection (shortname, (name, docstr)) =
>++ if shortname <> "" && name <> "" then begin
>++ if shortname = sect then sect_idx := !idx;
>++ incr idx;
>++ let item = GMenu.menu_item ~label:name ~packing:menu#append () in
>++ ignore
>++ (item#connect#activate ~callback:(fun () -> t_text#insert docstr))
>++ end
>++ in
>++ Safelist.iter addDocSection Strings.docs;
>++
>++ t#show ()
>++
>++(* ------ *)
>++
>++let messageBox ~title ?(action = fun t -> t#destroy) message =
>++ let utitle = transcode title in
>++ let t = GWindow.dialog ~title:utitle ~position:`CENTER () in
>++ let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in
>++ t_dismiss#grab_default ();
>++ ignore (t_dismiss#connect#clicked ~callback:(action t));
>++ let t_text =
>++ new scrolled_text ~editable:false
>++ ~width:80 ~height:20 ~packing:t#vbox#add ()
>++ in
>++ t_text#insert message;
>++ ignore (t#event#connect#delete ~callback:(fun _ -> action t (); true));
>++ t#show ()
>++
>++(* twoBoxAdvanced: Display a message in a window and wait for the user
>++ to hit one of two buttons. Return true if the first button is
>++ chosen, false if the second button is chosen. Also has a button for
>++ showing more details to the user in a messageBox dialog *)
>++let twoBoxAdvanced
>++ ~parent ~title ~message ~longtext ~advLabel ~astock ~bstock =
>++ let t =
>++ GWindow.dialog ~parent ~border_width:6 ~modal:true
>++ ~resizable:false () in
>++ t#vbox#set_spacing 12;
>++ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>++ ignore (GMisc.image ~stock:`DIALOG_QUESTION ~icon_size:`DIALOG
>++ ~yalign:0. ~packing:h1#pack ());
>++ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>++ ignore (GMisc.label
>++ ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)
>++ ~selectable:true ~yalign:0. ~packing:v1#add ());
>++ t#add_button_stock `CANCEL `NO;
>++ let cmd () =
>++ messageBox ~title:"Details" longtext
>++ in
>++ t#add_button advLabel `HELP;
>++ t#add_button_stock `APPLY `YES;
>++ t#set_default_response `NO;
>++ let res = ref false in
>++ let setRes signal =
>++ match signal with
>++ `YES -> res := true; t#destroy ()
>++ | `NO -> res := false; t#destroy ()
>++ | `HELP -> cmd ()
>++ | _ -> ()
>++ in
>++ ignore (t#connect#response ~callback:setRes);
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ t#show();
>++ GMain.Main.main();
>++ !res
>++
>++let summaryBox ~parent ~title ~message ~f =
>++ let t =
>++ GWindow.dialog ~parent ~border_width:6 ~modal:true
>++ ~resizable:false ~focus_on_map:false () in
>++ t#vbox#set_spacing 12;
>++ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
>++ ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG
>++ ~yalign:0. ~packing:h1#pack ());
>++ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
>++ ignore (GMisc.label
>++ ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)
>++ ~selectable:true ~xalign:0. ~yalign:0. ~packing:v1#add ());
>++ let exp = GBin.expander ~spacing:12 ~label:"Show details" ~packing:v1#add () in
>++ let t_text =
>++ new scrolled_text ~editable:false ~shadow_type:`IN
>++ ~width:60 ~height:10 ~packing:exp#add ()
>++ in
>++ f (t_text#text);
>++ t#add_button_stock `OK `OK;
>++ t#set_default_response `OK;
>++ let setRes signal = t#destroy () in
>++ ignore (t#connect#response ~callback:setRes);
>++ ignore (t#connect#destroy ~callback:GMain.Main.quit);
>++ t#show();
>++ GMain.Main.main()
>++
>++(**********************************************************************
>++ TOP-LEVEL WINDOW
>++ **********************************************************************)
>++
>++let displayWaitMessage () =
>++ make_busy (toplevelWindow ());
>++ Trace.status (Uicommon.contactingServerMsg ())
>++
>++(* ------ *)
>++
>++type status = NoStatus | Done | Failed
>++
>++let createToplevelWindow () =
>++ let toplevelWindow =
>++ GWindow.window ~kind:`TOPLEVEL ~position:`CENTER
>++ ~title:myNameCapitalized ()
>++ in
>++ setToplevelWindow toplevelWindow;
>++ (* There is already a default icon under Windows, and transparent
>++ icons are not supported by all version of Windows *)
>++ if Util.osType <> `Win32 then toplevelWindow#set_icon (Some icon);
>++ let toplevelVBox = GPack.vbox ~packing:toplevelWindow#add () in
>++
>++ (*******************************************************************
>++ Statistic window
>++ *******************************************************************)
>++
>++ let (statWin, startStats, stopStats) = statistics () in
>++
>++ (*******************************************************************
>++ Groups of things that are sensitive to interaction at the same time
>++ *******************************************************************)
>++ let grAction = ref [] in
>++ let grDiff = ref [] in
>++ let grGo = ref [] in
>++ let grRescan = ref [] in
>++ let grDetail = ref [] in
>++ let grAdd gr w = gr := w#misc::!gr in
>++ let grSet gr st = Safelist.iter (fun x -> x#set_sensitive st) !gr in
>++ let grDisactivateAll () =
>++ grSet grAction false;
>++ grSet grDiff false;
>++ grSet grGo false;
>++ grSet grRescan false;
>++ grSet grDetail false
>++ in
>++
>++ (*********************************************************************
>++ Create the menu bar
>++ *********************************************************************)
>++ let topHBox = GPack.hbox ~packing:(toplevelVBox#pack ~expand:false) () in
>++
>++ let menuBar =
>++ GMenu.menu_bar ~border_width:0
>++ ~packing:(topHBox#pack ~expand:true) () in
>++ let menus = new gMenuFactory ~accel_modi:[] menuBar in
>++ let accel_group = menus#accel_group in
>++ toplevelWindow#add_accel_group accel_group;
>++ let add_submenu ?(modi=[]) label =
>++ let (menu, item) = menus#add_submenu label in
>++ (new gMenuFactory ~accel_group:(menus#accel_group)
>++ ~accel_path:(menus#accel_path ^ label ^ "/")
>++ ~accel_modi:modi menu,
>++ item)
>++ in
>++ let replace_submenu ?(modi=[]) label item =
>++ let menu = menus#replace_submenu item in
>++ new gMenuFactory ~accel_group:(menus#accel_group)
>++ ~accel_path:(menus#accel_path ^ label ^ "/")
>++ ~accel_modi:modi menu
>++ in
>++
>++ let profileLabel =
>++ GMisc.label ~text:"" ~packing:(topHBox#pack ~expand:false ~padding:2) () in
>++
>++ let displayNewProfileLabel () =
>++ let p = match !Prefs.profileName with None -> "" | Some p -> p in
>++ let label = Prefs.read Uicommon.profileLabel in
>++ let s =
>++ match p, label with
>++ "", _ -> ""
>++ | _, "" -> p
>++ | "default", _ -> label
>++ | _ -> Format.sprintf "%s (%s)" p label
>++ in
>++ toplevelWindow#set_title
>++ (if s = "" then myNameCapitalized else
>++ Format.sprintf "%s [%s]" myNameCapitalized s);
>++ let s = if s="" then "No profile" else "Profile: " ^ s in
>++ profileLabel#set_text (transcode s)
>++ in
>++ displayNewProfileLabel ();
>++
>++ (*********************************************************************
>++ Create the menus
>++ *********************************************************************)
>++ let (fileMenu, _) = add_submenu "_Synchronization" in
>++ let (actionMenu, actionItem) = add_submenu "_Actions" in
>++ let (ignoreMenu, _) = add_submenu ~modi:[`SHIFT] "_Ignore" in
>++ let (sortMenu, _) = add_submenu "S_ort" in
>++ let (helpMenu, _) = add_submenu "_Help" in
>++
>++ (*********************************************************************
>++ Action bar
>++ *********************************************************************)
>++ let actionBar =
>++ GButton.toolbar ~style:`BOTH
>++ (* 2003-0519 (stse): how to set space size in gtk 2.0? *)
>++ (* Answer from Jacques Garrigue: this can only be done in
>++ the user's.gtkrc, not programmatically *)
>++ ~orientation:`HORIZONTAL (* ~space_size:10 *)
>++ ~packing:(toplevelVBox#pack ~expand:false) () in
>++
>++ (*********************************************************************
>++ Create the main window
>++ *********************************************************************)
>++ let mainWindowSW =
>++ GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:true)
>++ ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
>++ in
>++ let sizeMainWindow () =
>++ let ctx = mainWindowSW#misc#pango_context in
>++ let metrics = ctx#get_metrics () in
>++ let h = GPango.to_pixels (metrics#ascent+metrics#descent) in
>++ toplevelWindow#set_default_height
>++ ((h + 3) * (Prefs.read Uicommon.mainWindowHeight + 1) + 200)
>++ in
>++ let cols = new GTree.column_list in
>++ let c_replica1 = cols#add Gobject.Data.string in
>++ let c_action = cols#add Gobject.Data.gobject in
>++ let c_replica2 = cols#add Gobject.Data.string in
>++ let c_status = cols#add Gobject.Data.gobject_option in
>++ let c_statust = cols#add Gobject.Data.string in
>++ let c_path = cols#add Gobject.Data.string in
>++ (*let c_rowid = cols#add Gobject.Data.uint in*)
>++ (* With current implementation the [list_store] view model and [theState]
>++ array have one-to-one correspondence, so that list_store's tree path index
>++ is the same as theState array index.
>++ This changes when, for example, [tree_store] would be used instead of
>++ list_store, or a separate view-only sorting is implemented without sorting
>++ the backing theState array. In that case, the column [c_rowid] must be
>++ used to store the index of [theState] array in the view model. Tree path
>++ index must not be used directly as [theState] array index and vice versa. *)
>++ let mainWindowModel = GTree.list_store cols in
>++ let mainWindow =
>++ GTree.view ~model:mainWindowModel ~packing:(mainWindowSW#add)
>++ ~headers_clickable:false ~enable_search:false () in
>++ mainWindow#selection#set_mode `MULTIPLE;
>++ ignore (mainWindow#append_column
>++ (GTree.view_column
>++ ~title:(" ")
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_replica1]) ()));
>++ ignore (mainWindow#append_column
>++ (GTree.view_column ~title:" Action "
>++ ~renderer:(GTree.cell_renderer_pixbuf [], ["pixbuf", c_action]) ()));
>++ ignore (mainWindow#append_column
>++ (GTree.view_column
>++ ~title:(" ")
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_replica2]) ()));
>++ let status_view_col = GTree.view_column ~title:" Status "
>++ ~renderer:(GTree.cell_renderer_pixbuf [], ["pixbuf", c_status]) () in
>++ let status_t_rend = GTree.cell_renderer_text [] in
>++ status_view_col#pack ~expand:false ~from:`END status_t_rend;
>++ status_view_col#add_attribute status_t_rend "text" c_statust;
>++ ignore (mainWindow#append_column status_view_col);
>++ ignore (mainWindow#append_column
>++ (GTree.view_column ~title:" Path "
>++ ~renderer:(GTree.cell_renderer_text [], ["text", c_path]) ()));
>++
>++ let setMainWindowColumnHeaders s =
>++ Array.iteri
>++ (fun i data ->
>++ (mainWindow#get_column i)#set_title data)
>++ [| " " ^ Unicode.protect (String.sub s 0 12) ^ " "; " Action ";
>++ " " ^ Unicode.protect (String.sub s 15 12) ^ " "; " Status ";
>++ " Path" |];
>++ in
>++ sizeMainWindow ();
>++
>++ (* See above for comment about tree path index and [theState] array index
>++ equivalence. *)
>++ let siOfRow f path =
>++ let row = mainWindowModel#get_iter path in
>++ let i = (GTree.Path.get_indices path).(0) in
>++ (*let i = mainWindowModel#get ~row ~column:c_rowid in*)
>++ f i !theState.(i) row
>++ in
>++ let rowOfSi i = GTree.Path.create [i] in
>++ let currentNumberRows () = mainWindow#selection#count_selected_rows in
>++ let currentRow () =
>++ match currentNumberRows () with
>++ | 1 -> siOfRow (fun i si row -> Some (i, !theState.(i), row))
>++ (List.hd mainWindow#selection#get_selected_rows)
>++ | _ -> None
>++ in
>++ let currentSelectedIter f =
>++ Safelist.iter (fun r -> siOfRow f r)
>++ mainWindow#selection#get_selected_rows
>++ in
>++ let currentSelectedFold f a =
>++ Safelist.fold_left (fun a r -> siOfRow (fun _ si _ -> f a si) r)
>++ a mainWindow#selection#get_selected_rows
>++ in
>++ let currentSelectedExists pred =
>++ Safelist.exists (fun r -> siOfRow (fun _ si _ -> pred si) r)
>++ mainWindow#selection#get_selected_rows
>++ in
>++
>++ (*********************************************************************
>++ Create the details window
>++ *********************************************************************)
>++
>++ let showDetCommand () =
>++ let details =
>++ match currentRow () with
>++ None ->
>++ None
>++ | Some (_, si, _) ->
>++ let path = Path.toString si.ri.path1 in
>++ match si.whatHappened with
>++ Some (Util.Failed _, Some det) ->
>++ Some ("Merge execution details for file" ^
>++ transcodeFilename path,
>++ det)
>++ | _ ->
>++ match si.ri.replicas with
>++ Problem err ->
>++ Some ("Errors for file " ^ transcodeFilename path, err)
>++ | Different diff ->
>++ let prefix s l =
>++ Safelist.map (fun err -> Format.sprintf "%s%s\n" s err) l
>++ in
>++ let errors =
>++ Safelist.append
>++ (prefix "[root 1]: " diff.errors1)
>++ (prefix "[root 2]: " diff.errors2)
>++ in
>++ let errors =
>++ match si.whatHappened with
>++ Some (Util.Failed err, _) -> err :: errors
>++ | _ -> errors
>++ in
>++ Some ("Errors for file " ^ transcodeFilename path,
>++ String.concat "\n" errors)
>++ in
>++ match details with
>++ None -> ((* Should not happen *))
>++ | Some (title, details) -> messageBox ~title (transcode details)
>++ in
>++
>++ let detailsWindowSW =
>++ GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
>++ ~shadow_type:`IN ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
>++ in
>++ let detailsWindow =
>++ GText.view ~editable:false ~packing:detailsWindowSW#add ()
>++ in
>++ let detailsWindowPath = detailsWindow#buffer#create_tag [] in
>++ let detailsWindowInfo =
>++ detailsWindow#buffer#create_tag [`FONT_DESC (Lazy.force fontMonospace)] in
>++ let detailsWindowError =
>++ detailsWindow#buffer#create_tag [`WRAP_MODE `WORD] in
>++ detailsWindow#misc#set_size_chars ~height:3 ~width:112 ();
>++ detailsWindow#misc#set_can_focus false;
>++
>++ let updateButtons () =
>++ if not !busy then
>++ let actionPossible si =
>++ match si.whatHappened, si.ri.replicas with
>++ None, Different _ -> true
>++ | _ -> false
>++ in
>++ match currentRow () with
>++ None ->
>++ grSet grAction (currentSelectedExists actionPossible);
>++ grSet grDiff false;
>++ grSet grDetail false
>++ | Some (_, si, _) ->
>++ let details =
>++ begin match si.ri.replicas with
>++ Different diff -> diff.errors1 <> [] || diff.errors2 <> []
>++ | Problem _ -> true
>++ end
>++ ||
>++ begin match si.whatHappened with
>++ Some (Util.Failed _, _) -> true
>++ | _ -> false
>++ end
>++ in
>++ grSet grDetail details;
>++ let activateAction = actionPossible si in
>++ let activateDiff =
>++ activateAction &&
>++ match si.ri.replicas with
>++ Different {rc1 = {typ = `FILE}; rc2 = {typ = `FILE}} ->
>++ true
>++ | _ ->
>++ false
>++ in
>++ grSet grAction activateAction;
>++ grSet grDiff activateDiff
>++ in
>++
>++ let makeRowVisible row =
>++ mainWindow#scroll_to_cell row status_view_col (* just a dummy column *)
>++ in
>++
>++(*
>++ let makeFirstUnfinishedVisible pRiInFocus =
>++ let im = Array.length !theState in
>++ let rec find i =
>++ if i >= im then makeRowVisible im else
>++ match pRiInFocus (!theState.(i).ri), !theState.(i).whatHappened with
>++ true, None -> makeRowVisible i
>++ | _ -> find (i+1) in
>++ find 0
>++ in
>++*)
>++
>++ let updateDetails () =
>++ begin match currentRow () with
>++ None ->
>++ detailsWindow#buffer#set_text ""
>++ | Some (_, si, _) ->
>++ let (formated, details) =
>++ match si.whatHappened with
>++ | Some(Util.Failed(s), _) ->
>++ (false, s)
>++ | None | Some(Util.Succeeded, _) ->
>++ match si.ri.replicas with
>++ Problem _ ->
>++ (false, Uicommon.details2string si.ri " ")
>++ | Different _ ->
>++ (true, Uicommon.details2string si.ri " ")
>++ in
>++ let path = Path.toString si.ri.path1 in
>++ detailsWindow#buffer#set_text "";
>++ detailsWindow#buffer#insert ~tags:[detailsWindowPath]
>++ (transcodeFilename path);
>++ let len = String.length details in
>++ let details =
>++ if details.[len - 1] = '\n' then String.sub details 0 (len - 1)
>++ else details
>++ in
>++ if details <> "" then
>++ detailsWindow#buffer#insert
>++ ~tags:[if formated then detailsWindowInfo else detailsWindowError]
>++ ("\n" ^ transcode details)
>++ end;
>++ (* Display text *)
>++ updateButtons () in
>++
>++ (*********************************************************************
>++ Status window
>++ *********************************************************************)
>++
>++ let statusHBox = GPack.hbox ~packing:(toplevelVBox#pack ~expand:false) () in
>++
>++ let progressBar =
>++ GRange.progress_bar ~packing:(statusHBox#pack ~expand:false) () in
>++
>++ progressBar#misc#set_size_chars ~height:1 ~width:28 ();
>++ progressBar#set_show_text true;
>++ progressBar#set_pulse_step 0.02;
>++ let progressBarPulse = ref false in
>++
>++ let statusWindow =
>++ GMisc.statusbar ~packing:(statusHBox#pack ~expand:true) () in
>++ let statusContext = statusWindow#new_context ~name:"status" in
>++ ignore (statusContext#push "");
>++
>++ let displayStatus m =
>++ statusContext#pop ();
>++ if !progressBarPulse then progressBar#pulse ();
>++ ignore (statusContext#push (transcode m));
>++ (* Force message to be displayed immediately *)
>++ gtk_sync false
>++ in
>++
>++ let formatStatus major minor = (Util.padto 30 (major ^ " ")) ^ minor in
>++
>++ (* Tell the Trace module about the status printer *)
>++ Trace.messageDisplayer := displayStatus;
>++ Trace.statusFormatter := formatStatus;
>++ Trace.sendLogMsgsToStderr := false;
>++
>++ (*********************************************************************
>++ Functions used to print in the main window
>++ *********************************************************************)
>++ let delayUpdates = ref false in
>++
>++ let select row scroll =
>++ delayUpdates := true;
>++ mainWindow#selection#unselect_all ();
>++ mainWindow#selection#select_path row;
>++ mainWindow#set_cursor row status_view_col (* just a dummy column *);
>++ delayUpdates := false;
>++ if scroll then makeRowVisible row;
>++ updateDetails ()
>++ in
>++ let selectI i scroll = select (rowOfSi i) scroll in
>++
>++ ignore (mainWindow#selection#connect#changed ~callback:
>++ (fun () -> if not !delayUpdates then updateDetails ()));
>++
>++ let nextInteresting () =
>++ let l = Array.length !theState in
>++ let start = match currentRow () with Some (i, _, _) -> i + 1 | None -> 0 in
>++ let rec loop i =
>++ if i < l then
>++ match !theState.(i).ri.replicas with
>++ Different {direction = dir}
>++ when not (Prefs.read Uicommon.auto) || isConflict dir ->
>++ selectI i true
>++ | _ ->
>++ loop (i + 1) in
>++ loop start in
>++ let selectSomethingIfPossible () =
>++ if currentNumberRows () = 0 then nextInteresting () in
>++
>++ let columnsOf si =
>++ let oldPath = Path.empty in
>++ let status =
>++ match si.ri.replicas with
>++ Different {direction = Conflict _} | Problem _ ->
>++ NoStatus
>++ | _ ->
>++ match si.whatHappened with
>++ None -> NoStatus
>++ | Some (Util.Succeeded, _) -> Done
>++ | Some (Util.Failed _, _) -> Failed
>++ in
>++ let (r1, action, r2, path) =
>++ Uicommon.reconItem2stringList oldPath si.ri in
>++ (r1, action, r2, status, path)
>++ in
>++
>++ let greenPixel = "00dd00" in
>++ let redPixel = "ff2040" in
>++ let lightbluePixel = "8888FF" in
>++ let orangePixel = "ff9303" in
>++(*
>++ let yellowPixel = "999900" in
>++ let blackPixel = "000000" in
>++*)
>++ let buildPixmap p =
>++ GdkPixbuf.from_xpm_data p in
>++ let buildPixmaps f c1 =
>++ (buildPixmap (f c1), buildPixmap (f lightbluePixel)) in
>++
>++ let doneIcon = buildPixmap Pixmaps.success in
>++ let failedIcon = buildPixmap Pixmaps.failure in
>++ let rightArrow = buildPixmaps Pixmaps.copyAB greenPixel in
>++ let leftArrow = buildPixmaps Pixmaps.copyBA greenPixel in
>++ let orangeRightArrow = buildPixmaps Pixmaps.copyAB orangePixel in
>++ let orangeLeftArrow = buildPixmaps Pixmaps.copyBA orangePixel in
>++ let ignoreAct = buildPixmaps Pixmaps.ignore redPixel in
>++ let failedIcons = (failedIcon, failedIcon) in
>++ let mergeLogo = buildPixmaps Pixmaps.mergeLogo greenPixel in
>++(*
>++ let rightArrowBlack = buildPixmap (Pixmaps.copyAB blackPixel) in
>++ let leftArrowBlack = buildPixmap (Pixmaps.copyBA blackPixel) in
>++ let mergeLogoBlack = buildPixmap (Pixmaps.mergeLogo blackPixel) in
>++*)
>++
>++ let getArrow j action =
>++ let changedFromDefault = match !theState.(j).ri.replicas with
>++ Different diff -> diff.direction <> diff.default_direction
>++ | _ -> false in
>++ let sel pixmaps =
>++ if changedFromDefault then snd pixmaps else fst pixmaps in
>++ let pixmaps =
>++ match action with
>++ Uicommon.AError -> failedIcons
>++ | Uicommon.ASkip _ -> ignoreAct
>++ | Uicommon.ALtoR false -> rightArrow
>++ | Uicommon.ALtoR true -> orangeRightArrow
>++ | Uicommon.ARtoL false -> leftArrow
>++ | Uicommon.ARtoL true -> orangeLeftArrow
>++ | Uicommon.AMerge -> mergeLogo
>++ in
>++ sel pixmaps
>++ in
>++
>++
>++ let getStatusIcon = function
>++ | Failed -> Some failedIcon
>++ | Done -> Some doneIcon
>++ | NoStatus -> None in
>++
>++ let displayRowAction row i action =
>++ mainWindowModel#set ~row ~column:c_action (getArrow i action) in
>++ let displayRowStatus row status =
>++ mainWindowModel#set ~row ~column:c_status (getStatusIcon status);
>++ if status <> NoStatus then
>++ mainWindowModel#set ~row ~column:c_statust "" in
>++ let displayRowPath row path =
>++ mainWindowModel#set ~row ~column:c_path (transcodeFilename path) in
>++ let displayRow row i r1 r2 action status path =
>++ mainWindowModel#set ~row ~column:c_replica1 r1;
>++ mainWindowModel#set ~row ~column:c_replica2 r2;
>++ displayRowAction row i action;
>++ displayRowStatus row status;
>++ displayRowPath row path;
>++ (*mainWindowModel#set ~row ~column:c_rowid i;*)
>++ in
>++
>++ let displayMain() =
>++ (* The call to mainWindow#clear below side-effect current,
>++ so we save the current value before we clear out the main window and
>++ rebuild it. *)
>++ let savedCurrent = mainWindow#selection#get_selected_rows in
>++ mainWindow#set_model None;
>++ mainWindowModel#clear ();
>++ let tot = Array.length !theState - 1 in
>++ let totf = float_of_int (tot + 1) in
>++ progressBar#set_text (Printf.sprintf "Displaying %i items..." (tot + 1));
>++ for i = 0 to tot do
>++ if i mod 1024 = 0 then begin
>++ progressBar#set_fraction (max 0. (min 1. ((float_of_int i) /. totf)));
>++ gtk_sync false
>++ end;
>++
>++ let (r1, action, r2, status, path) = columnsOf !theState.(i) in
>++
>++ let row = mainWindowModel#append () in
>++ displayRow row i r1 r2 action status path;
>++ done;
>++ mainWindow#set_model (Some mainWindowModel#coerce);
>++ match savedCurrent with
>++ | [] -> selectSomethingIfPossible ()
>++ | [x] -> select x true
>++ | _ -> Safelist.iter (fun p -> mainWindow#selection#select_path p) savedCurrent;
>++
>++ progressBar#set_text ""; progressBar#set_fraction 0.;
>++ updateDetails (); (* Do we need this line? *)
>++ in
>++
>++ let redisplay i si iter =
>++ let (_, action, _, status, path) = columnsOf si in
>++ displayRowAction iter i action;
>++ displayRowStatus iter status;
>++ if status = Failed then displayRowPath iter (path ^
>++ " [failed: click on this line for details]");
>++ in
>++
>++ let fastRedisplay i =
>++ let si = !theState.(i) in
>++ let iter = mainWindowModel#get_iter (rowOfSi i) in
>++ let (_, action, _, status, path) = columnsOf si in
>++ displayRowStatus iter status;
>++ if status = Failed then begin
>++ displayRowPath iter (path ^
>++ " [failed: click on this line for details]");
>++ match currentRow () with
>++ | Some (_, csi, _) when csi = si -> updateDetails ()
>++ | Some _ | None -> ()
>++ end
>++ in
>++
>++ let updateRowStatus i newstatus =
>++ let row = mainWindowModel#get_iter (rowOfSi i) in
>++ let oldstatus = mainWindowModel#get ~row ~column:c_statust in
>++ if oldstatus <> newstatus then mainWindowModel#set ~row ~column:c_statust newstatus
>++ in
>++
>++ let totalBytesToTransfer = ref Uutil.Filesize.zero in
>++ let totalBytesTransferred = ref Uutil.Filesize.zero in
>++
>++ let t0 = ref 0. in
>++ let t1 = ref 0. in
>++ let lastFrac = ref 0. in
>++ let oldWritten = ref 0. in
>++ let writeRate = ref 0. in
>++ let displayGlobalProgress v =
>++ if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
>++ lastFrac := v;
>++ progressBar#set_fraction (max 0. (min 1. (v /. 100.)))
>++ end;
>++ if v < 0.001 then
>++ progressBar#set_text " "
>++ else begin
>++ let t = Unix.gettimeofday () in
>++ let delta = t -. !t1 in
>++ if delta >= 0.5 then begin
>++ t1 := t;
>++ let remTime =
>++ if v >= 100. then "00:00 remaining" else
>++ let t = truncate ((!t1 -. !t0) *. (100. -. v) /. v +. 0.5) in
>++ Format.sprintf "%02d:%02d remaining" (t / 60) (t mod 60)
>++ in
>++ let written = !clientWritten +. !serverWritten in
>++ let b = 0.64 ** delta in
>++ writeRate :=
>++ b *. !writeRate +.
>++ (1. -. b) *. (written -. !oldWritten) /. delta;
>++ oldWritten := written;
>++ let rate = !writeRate (*!emitRate2 +. !receiveRate2*) in
>++ let txt =
>++ if rate > 99. then
>++ Format.sprintf "%s (%s)" remTime (rate2str rate)
>++ else
>++ remTime
>++ in
>++ progressBar#set_text txt
>++ end
>++ end
>++ in
>++
>++ let showGlobalProgress b =
>++ (* Concatenate the new message *)
>++ totalBytesTransferred := Uutil.Filesize.add !totalBytesTransferred b;
>++ let v =
>++ (Uutil.Filesize.percentageOfTotalSize
>++ !totalBytesTransferred !totalBytesToTransfer)
>++ in
>++ displayGlobalProgress v
>++ in
>++
>++ let root1IsLocal = ref true in
>++ let root2IsLocal = ref true in
>++
>++ let initGlobalProgress b =
>++ let (root1,root2) = Globals.roots () in
>++ root1IsLocal := fst root1 = Local;
>++ root2IsLocal := fst root2 = Local;
>++ totalBytesToTransfer := b;
>++ totalBytesTransferred := Uutil.Filesize.zero;
>++ t0 := Unix.gettimeofday (); t1 := !t0;
>++ writeRate := 0.; oldWritten := !clientWritten +. !serverWritten;
>++ displayGlobalProgress 0.
>++ in
>++
>++ let showProgress i bytes dbg =
>++ let i = Uutil.File.toLine i in
>++ let item = !theState.(i) in
>++ item.bytesTransferred <- Uutil.Filesize.add item.bytesTransferred bytes;
>++ let b = item.bytesTransferred in
>++ let len = item.bytesToTransfer in
>++ let newstatus =
>++ if b = Uutil.Filesize.zero || len = Uutil.Filesize.zero then "start "
>++ else if len = Uutil.Filesize.zero then
>++ Printf.sprintf "%5s " (Uutil.Filesize.toString b)
>++ else Util.percent2string (Uutil.Filesize.percentageOfTotalSize b len) in
>++ let dbg = if Trace.enabled "progress" then dbg ^ "/" else "" in
>++ let newstatus = dbg ^ newstatus in
>++ updateRowStatus i newstatus;
>++ showGlobalProgress bytes;
>++ gtk_sync false;
>++ begin match item.ri.replicas with
>++ Different diff ->
>++ begin match diff.direction with
>++ Replica1ToReplica2 ->
>++ if !root2IsLocal then
>++ clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes
>++ else
>++ serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes
>++ | Replica2ToReplica1 ->
>++ if !root1IsLocal then
>++ clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes
>++ else
>++ serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes
>++ | Conflict _ | Merge ->
>++ (* Diff / merge *)
>++ clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes
>++ end
>++ | _ ->
>++ assert false
>++ end
>++ in
>++
>++ (* Install showProgress so that we get called back by low-level
>++ file transfer stuff *)
>++ Uutil.setProgressPrinter showProgress;
>++
>++ (* Apply new ignore patterns to the current state, expecting that the
>++ number of reconitems will grow smaller. Adjust the display, being
>++ careful to keep the cursor as near as possible to its position
>++ before the new ignore patterns take effect. *)
>++ let ignoreAndRedisplay () =
>++ let lst = Array.to_list !theState in
>++ (* FIX: we should actually test whether any prefix is now ignored *)
>++ let keep sI = not (Globals.shouldIgnore sI.ri.path1) in
>++ theState := Array.of_list (Safelist.filter keep lst);
>++ displayMain() in
>++
>++ let sortAndRedisplay () =
>++ let compareRIs = Sortri.compareReconItems() in
>++ Array.stable_sort (fun si1 si2 -> compareRIs si1.ri si2.ri) !theState;
>++ displayMain() in
>++
>++ (******************************************************************
>++ Main detect-updates-and-reconcile logic
>++ ******************************************************************)
>++
>++ let commitUpdates () =
>++ Trace.status "Updating synchronizer state";
>++ let t = Trace.startTimer "Updating synchronizer state" in
>++ gtk_sync true;
>++ Update.commitUpdates();
>++ Trace.showTimer t
>++ in
>++
>++ let clearMainWindow () =
>++ grDisactivateAll ();
>++ make_busy toplevelWindow;
>++ mainWindowModel#clear ();
>++ detailsWindow#buffer#set_text ""
>++ in
>++
>++ let detectUpdatesAndReconcile () =
>++ clearMainWindow ();
>++ startStats ();
>++ progressBarPulse := true;
>++ sync_action := Some (fun () -> progressBar#pulse ());
>++ let findUpdates () =
>++ let t = Trace.startTimer "Checking for updates" in
>++ Trace.status "Looking for changes";
>++ let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in
>++ Trace.showTimer t;
>++ updates in
>++ let reconcile updates =
>++ let t = Trace.startTimer "Reconciling" in
>++ let reconRes = Recon.reconcileAll ~allowPartial:true updates in
>++ Trace.showTimer t;
>++ reconRes in
>++ let (reconItemList, thereAreEqualUpdates, dangerousPaths) =
>++ reconcile (findUpdates ()) in
>++ if not !Update.foundArchives then commitUpdates ();
>++ if reconItemList = [] then begin
>++ if !Update.foundArchives then commitUpdates ();
>++ if thereAreEqualUpdates then
>++ Trace.status
>++ "Replicas have been changed only in identical ways since last sync"
>++ else
>++ Trace.status "Everything is up to date"
>++ end else
>++ Trace.status "Check and/or adjust selected actions; then press Go";
>++ theState :=
>++ Array.of_list
>++ (Safelist.map
>++ (fun ri -> { ri = ri;
>++ bytesTransferred = Uutil.Filesize.zero;
>++ bytesToTransfer = Uutil.Filesize.zero;
>++ whatHappened = None })
>++ reconItemList);
>++ unsynchronizedPaths :=
>++ Some (Safelist.map (fun ri -> ri.path1) reconItemList, []);
>++ progressBarPulse := false; sync_action := None; displayGlobalProgress 0.;
>++ displayMain();
>++ progressBarPulse := false; sync_action := None; displayGlobalProgress 0.;
>++ stopStats ();
>++ grSet grGo (Array.length !theState > 0);
>++ grSet grRescan true;
>++ make_interactive toplevelWindow;
>++ if Prefs.read Globals.confirmBigDeletes then begin
>++ if dangerousPaths <> [] then begin
>++ Prefs.set Globals.batch false;
>++ Util.warn (Uicommon.dangerousPathMsg dangerousPaths)
>++ end;
>++ end;
>++ in
>++
>++ (*********************************************************************
>++ Help menu
>++ *********************************************************************)
>++ let addDocSection (shortname, (name, docstr)) =
>++ if shortname = "about" then
>++ ignore (helpMenu#add_image_item
>++ ~stock:`ABOUT ~callback:(fun () -> documentation shortname)
>++ name)
>++ else if shortname <> "" && name <> "" then
>++ ignore (helpMenu#add_item
>++ ~callback:(fun () -> documentation shortname)
>++ name) in
>++ Safelist.iter addDocSection Strings.docs;
>++
>++ (*********************************************************************
>++ Ignore menu
>++ *********************************************************************)
>++ let addRegExpByPath pathfunc =
>++ Util.StringSet.iter (fun pat -> Uicommon.addIgnorePattern pat)
>++ (currentSelectedFold
>++ (fun s si -> Util.StringSet.add (pathfunc si.ri.path1) s)
>++ Util.StringSet.empty);
>++ ignoreAndRedisplay ()
>++ in
>++ grAdd grAction
>++ (ignoreMenu#add_item ~key:GdkKeysyms._i
>++ ~callback:(fun () -> getLock (fun () ->
>++ addRegExpByPath Uicommon.ignorePath))
>++ "Permanently Ignore This _Path");
>++ grAdd grAction
>++ (ignoreMenu#add_item ~key:GdkKeysyms._E
>++ ~callback:(fun () -> getLock (fun () ->
>++ addRegExpByPath Uicommon.ignoreExt))
>++ "Permanently Ignore Files with this _Extension");
>++ grAdd grAction
>++ (ignoreMenu#add_item ~key:GdkKeysyms._N
>++ ~callback:(fun () -> getLock (fun () ->
>++ addRegExpByPath Uicommon.ignoreName))
>++ "Permanently Ignore Files with this _Name (in any Dir)");
>++
>++ (*
>++ grAdd grRescan
>++ (ignoreMenu#add_item ~callback:
>++ (fun () -> getLock ignoreDialog) "Edit ignore patterns");
>++ *)
>++
>++ (*********************************************************************
>++ Sort menu
>++ *********************************************************************)
>++ grAdd grRescan
>++ (sortMenu#add_item
>++ ~callback:(fun () -> getLock (fun () ->
>++ Sortri.sortByName();
>++ sortAndRedisplay()))
>++ "Sort by _Name");
>++ grAdd grRescan
>++ (sortMenu#add_item
>++ ~callback:(fun () -> getLock (fun () ->
>++ Sortri.sortBySize();
>++ sortAndRedisplay()))
>++ "Sort by _Size");
>++ grAdd grRescan
>++ (sortMenu#add_item
>++ ~callback:(fun () -> getLock (fun () ->
>++ Sortri.sortNewFirst();
>++ sortAndRedisplay()))
>++ "Sort Ne_w Entries First (toggle)");
>++ grAdd grRescan
>++ (sortMenu#add_item
>++ ~callback:(fun () -> getLock (fun () ->
>++ Sortri.restoreDefaultSettings();
>++ sortAndRedisplay()))
>++ "_Default Ordering");
>++
>++ (*********************************************************************
>++ Main function : synchronize
>++ *********************************************************************)
>++ let synchronize () =
>++ if Array.length !theState = 0 then
>++ Trace.status "Nothing to synchronize"
>++ else begin
>++ grDisactivateAll ();
>++ make_busy toplevelWindow;
>++
>++ Trace.status "Propagating changes";
>++ Transport.logStart ();
>++ let totalLength =
>++ Array.fold_left
>++ (fun l si ->
>++ si.bytesTransferred <- Uutil.Filesize.zero;
>++ let len =
>++ if si.whatHappened = None then Common.riLength si.ri else
>++ Uutil.Filesize.zero
>++ in
>++ si.bytesToTransfer <- len;
>++ Uutil.Filesize.add l len)
>++ Uutil.Filesize.zero !theState in
>++ initGlobalProgress totalLength;
>++ let t = Trace.startTimer "Propagating changes" in
>++ let im = Array.length !theState in
>++ let rec loop i actions pRiThisRound =
>++ if i < im then begin
>++ let theSI = !theState.(i) in
>++ let textDetailed = ref None in
>++ let action =
>++ match theSI.whatHappened with
>++ None ->
>++ if not (pRiThisRound theSI.ri) then
>++ return ()
>++ else
>++ catch (fun () ->
>++ Transport.transportItem
>++ theSI.ri (Uutil.File.ofLine i)
>++ (fun title text ->
>++ textDetailed := (Some text);
>++ if Prefs.read Uicommon.confirmmerge then
>++ twoBoxAdvanced
>++ ~parent:toplevelWindow
>++ ~title:title
>++ ~message:("Do you want to commit the changes to"
>++ ^ " the replicas ?")
>++ ~longtext:text
>++ ~advLabel:"View details..."
>++ ~astock:`YES
>++ ~bstock:`NO
>++ else
>++ true)
>++ >>= (fun () ->
>++ return Util.Succeeded))
>++ (fun e ->
>++ match e with
>++ Util.Transient s ->
>++ return (Util.Failed s)
>++ | _ ->
>++ fail e)
>++ >>= (fun res ->
>++ let rem =
>++ Uutil.Filesize.sub
>++ theSI.bytesToTransfer theSI.bytesTransferred
>++ in
>++ if rem <> Uutil.Filesize.zero then
>++ showProgress (Uutil.File.ofLine i) rem "done";
>++ theSI.whatHappened <- Some (res, !textDetailed);
>++ fastRedisplay i;
>++(* JV (7/09): It does not seem that useful to me to scroll the display
>++ to make the first unfinished item visible. The scrolling is way
>++ too fast, and it makes it impossible to browse the list. *)
>++(*
>++ sync_action :=
>++ Some
>++ (fun () ->
>++ makeFirstUnfinishedVisible pRiThisRound;
>++ sync_action := None);
>++*)
>++ gtk_sync false;
>++ return ())
>++ | Some _ ->
>++ return () (* Already processed this one (e.g. merged it) *)
>++ in
>++ loop (i + 1) (action :: actions) pRiThisRound
>++ end else
>++ actions
>++ in
>++ startStats ();
>++ Lwt_unix.run
>++ (let actions = loop 0 [] (fun ri -> not (Common.isDeletion ri)) in
>++ Lwt_util.join actions);
>++ Lwt_unix.run
>++ (let actions = loop 0 [] Common.isDeletion in
>++ Lwt_util.join actions);
>++ Transport.logFinish ();
>++ Trace.showTimer t;
>++ commitUpdates ();
>++ stopStats ();
>++
>++ let failureList =
>++ Array.fold_right
>++ (fun si l ->
>++ match si.whatHappened with
>++ Some (Util.Failed err, _) ->
>++ (si, [err], "transport failure") :: l
>++ | _ ->
>++ l)
>++ !theState []
>++ in
>++ let failureCount = List.length failureList in
>++ let failures =
>++ if failureCount = 0 then [] else
>++ [Printf.sprintf "%d failure%s"
>++ failureCount (if failureCount = 1 then "" else "s")]
>++ in
>++ let partialList =
>++ Array.fold_right
>++ (fun si l ->
>++ match si.whatHappened with
>++ Some (Util.Succeeded, _)
>++ when partiallyProblematic si.ri &&
>++ not (problematic si.ri) ->
>++ let errs =
>++ match si.ri.replicas with
>++ Different diff -> diff.errors1 @ diff.errors2
>++ | _ -> assert false
>++ in
>++ (si, errs,
>++ "partial transfer (errors during update detection)") :: l
>++ | _ ->
>++ l)
>++ !theState []
>++ in
>++ let partialCount = List.length partialList in
>++ let partials =
>++ if partialCount = 0 then [] else
>++ [Printf.sprintf "%d partially transferred" partialCount]
>++ in
>++ let skippedList =
>++ Array.fold_right
>++ (fun si l ->
>++ match si.ri.replicas with
>++ Problem err ->
>++ (si, [err], "error during update detection") :: l
>++ | Different diff when isConflict diff.direction ->
>++ (si, [],
>++ if isConflict diff.default_direction then
>++ "conflict"
>++ else "skipped") :: l
>++ | _ ->
>++ l)
>++ !theState []
>++ in
>++ let skippedCount = List.length skippedList in
>++ let skipped =
>++ if skippedCount = 0 then [] else
>++ [Printf.sprintf "%d skipped" skippedCount]
>++ in
>++ unsynchronizedPaths :=
>++ Some (Safelist.map (fun (si, _, _) -> si.ri.path1)
>++ (failureList @ partialList @ skippedList),
>++ []);
>++ Trace.status
>++ (Printf.sprintf "Synchronization complete %s"
>++ (String.concat ", " (failures @ partials @ skipped)));
>++ displayGlobalProgress 0.;
>++
>++ grSet grRescan true;
>++ make_interactive toplevelWindow;
>++
>++ let totalCount = failureCount + partialCount + skippedCount in
>++ if totalCount > 0 then begin
>++ let format n item sing plur =
>++ match n with
>++ 0 -> []
>++ | 1 -> [Format.sprintf "one %s%s" item sing]
>++ | n -> [Format.sprintf "%d %s%s" n item plur]
>++ in
>++ let infos =
>++ format failureCount "failure" "" "s" @
>++ format partialCount "partially transferred director" "y" "ies" @
>++ format skippedCount "skipped item" "" "s"
>++ in
>++ let message =
>++ (if failureCount = 0 then "The synchronization was successful.\n\n"
>++ else "") ^
>++ "The replicas are not fully synchronized.\n" ^
>++ (if totalCount < 2 then "There was" else "There were") ^
>++ begin match infos with
>++ [] -> assert false
>++ | [x] -> " " ^ x
>++ | l -> ":\n - " ^ String.concat ";\n - " l
>++ end ^
>++ "."
>++ in
>++ summaryBox ~parent:toplevelWindow
>++ ~title:"Synchronization summary" ~message ~f:
>++ (fun t ->
>++ let bullet = "\xe2\x80\xa2 " in
>++ let layout = Pango.Layout.create t#misc#pango_context#as_context in
>++ Pango.Layout.set_text layout bullet;
>++ let (n, _) = Pango.Layout.get_pixel_size layout in
>++ let path =
>++ t#buffer#create_tag [`FONT_DESC (Lazy.force fontBold)] in
>++ let description =
>++ t#buffer#create_tag [`FONT_DESC (Lazy.force fontItalic)] in
>++ let errorFirstLine =
>++ t#buffer#create_tag [`LEFT_MARGIN (n); `INDENT (- n)] in
>++ let errorNextLines =
>++ t#buffer#create_tag [`LEFT_MARGIN (2 * n)] in
>++ List.iter
>++ (fun (si, errs, desc) ->
>++ t#buffer#insert ~tags:[path]
>++ (transcodeFilename (Path.toString si.ri.path1));
>++ t#buffer#insert ~tags:[description]
>++ (" \xe2\x80\x94 " ^ desc ^ "\n");
>++ List.iter
>++ (fun err ->
>++ let errl =
>++ Str.split (Str.regexp_string "\n") (transcode err) in
>++ match errl with
>++ [] ->
>++ ()
>++ | f :: rem ->
>++ t#buffer#insert ~tags:[errorFirstLine]
>++ (bullet ^ f ^ "\n");
>++ List.iter
>++ (fun n ->
>++ t#buffer#insert ~tags:[errorNextLines]
>++ (n ^ "\n"))
>++ rem)
>++ errs)
>++ (failureList @ partialList @ skippedList))
>++ end
>++
>++ end in
>++
>++ (*********************************************************************
>++ Buttons for -->, M, <--, Skip
>++ *********************************************************************)
>++ let doActionOnRow f i theSI iter =
>++ begin match theSI.whatHappened, theSI.ri.replicas with
>++ None, Different diff ->
>++ f theSI.ri diff;
>++ redisplay i theSI iter
>++ | _ ->
>++ ()
>++ end
>++ in
>++ let doAction f =
>++ match currentRow () with
>++ Some (i, si, iter) ->
>++ doActionOnRow f i si iter;
>++ nextInteresting ()
>++ | None ->
>++ currentSelectedIter (fun i si iter -> doActionOnRow f i si iter);
>++ updateDetails ()
>++ in
>++ let leftAction _ =
>++ doAction (fun _ diff -> diff.direction <- Replica2ToReplica1) in
>++ let rightAction _ =
>++ doAction (fun _ diff -> diff.direction <- Replica1ToReplica2) in
>++ let questionAction _ = doAction (fun _ diff -> diff.direction <- Conflict "") in
>++ let mergeAction _ = doAction (fun _ diff -> diff.direction <- Merge) in
>++
>++ let insert_button (toolbar : #GButton.toolbar) ~stock ~text ~tooltip ~callback () =
>++ let b = GButton.tool_button ~stock ~label:text ~packing:toolbar#insert () in
>++ ignore (b#connect#clicked ~callback);
>++ b#misc#set_tooltip_text tooltip;
>++ b
>++ in
>++
>++(* actionBar#insert_space ();*)
>++ grAdd grAction
>++ (insert_button actionBar
>++ ~stock:`GO_FORWARD
>++ ~text:"Left to Right"
>++ ~tooltip:"Propagate selected items\n\
>++ from the left replica to the right one"
>++ ~callback:rightAction ());
>++(* actionBar#insert_space ();*)
>++ grAdd grAction
>++ (insert_button actionBar ~text:"Skip"
>++ ~stock:`NO
>++ ~tooltip:"Skip selected items"
>++ ~callback:questionAction ());
>++(* actionBar#insert_space ();*)
>++ grAdd grAction
>++ (insert_button actionBar
>++ ~stock:`GO_BACK
>++ ~text:"Right to Left"
>++ ~tooltip:"Propagate selected items\n\
>++ from the right replica to the left one"
>++ ~callback:leftAction ());
>++(* actionBar#insert_space ();*)
>++ grAdd grAction
>++ (insert_button actionBar
>++ ~stock:`ADD
>++ ~text:"Merge"
>++ ~tooltip:"Merge selected files"
>++ ~callback:mergeAction ());
>++
>++ (*********************************************************************
>++ Diff / merge buttons
>++ *********************************************************************)
>++ let diffCmd () =
>++ match currentRow () with
>++ Some (i, item, _) ->
>++ getLock (fun () ->
>++ let len =
>++ match item.ri.replicas with
>++ Problem _ ->
>++ Uutil.Filesize.zero
>++ | Different diff ->
>++ snd (if !root1IsLocal then diff.rc2 else diff.rc1).size
>++ in
>++ item.bytesTransferred <- Uutil.Filesize.zero;
>++ item.bytesToTransfer <- len;
>++ initGlobalProgress len;
>++ startStats ();
>++ Uicommon.showDiffs item.ri
>++ (fun title text ->
>++ messageBox ~title:(transcode title) (transcode text))
>++ Trace.status (Uutil.File.ofLine i);
>++ stopStats ();
>++ displayGlobalProgress 0.;
>++ fastRedisplay i)
>++ | None ->
>++ () in
>++
>++ actionBar#insert (GButton.separator_tool_item ());
>++ grAdd grDiff (insert_button actionBar ~text:"Diff"
>++ ~stock:`DIALOG_INFO
>++ ~tooltip:"Compare the two files at each replica"
>++ ~callback:diffCmd ());
>++
>++ (*********************************************************************
>++ Detail button
>++ *********************************************************************)
>++(* actionBar#insert_space ();*)
>++ grAdd grDetail (insert_button actionBar ~text:"Details"
>++ ~stock:`INFO
>++ ~tooltip:"Show detailed information about\n\
>++ an item, when available"
>++ ~callback:showDetCommand ());
>++
>++ (*********************************************************************
>++ Quit button
>++ *********************************************************************)
>++(* actionBar#insert_space ();
>++ ignore (actionBar#insert_button ~text:"Quit"
>++ ~icon:((GMisc.image ~stock:`QUIT ())#coerce)
>++ ~tooltip:"Exit Unison"
>++ ~callback:safeExit ());
>++*)
>++
>++ (*********************************************************************
>++ go button
>++ *********************************************************************)
>++ actionBar#insert (GButton.separator_tool_item ());
>++ grAdd grGo
>++ (insert_button actionBar ~text:"Go"
>++ (* tooltip:"Go with displayed actions" *)
>++ ~stock:`EXECUTE
>++ ~tooltip:"Perform the synchronization"
>++ ~callback:(fun () ->
>++ getLock synchronize) ());
>++
>++ (* Does not quite work: too slow, and Files.copy must be modifed to
>++ support an interruption without error. *)
>++ (*
>++ ignore (actionBar#insert_button ~text:"Stop"
>++ ~icon:((GMisc.image ~stock:`STOP ())#coerce)
>++ ~tooltip:"Exit Unison"
>++ ~callback:Abort.all ());
>++ *)
>++
>++ (*********************************************************************
>++ Rescan button
>++ *********************************************************************)
>++ let updateFromProfile = ref (fun () -> ()) in
>++
>++ let prepDebug () =
>++ if Sys.os_type = "Win32" then
>++ (* As a side-effect, this allocates a console if the process doesn't
>++ have one already. This call is here only for the side-effect,
>++ because debugging output is produced on stderr and the GUI will
>++ crash if there is no stderr. *)
>++ try ignore (System.terminalStateFunctions ())
>++ with Unix.Unix_error _ -> ()
>++ in
>++
>++ let loadProfile p reload =
>++ debug (fun()-> Util.msg "Loading profile %s..." p);
>++ Trace.status "Loading profile";
>++ unsynchronizedPaths := None;
>++ Uicommon.initPrefs ~profileName:p
>++ ~displayWaitMessage:(fun () -> if not reload then displayWaitMessage ())
>++ ~getFirstRoot ~getSecondRoot ~prepDebug ~termInteract ();
>++ !updateFromProfile ()
>++ in
>++
>++ let reloadProfile () =
>++ let n =
>++ match !Prefs.profileName with
>++ None -> assert false
>++ | Some n -> n
>++ in
>++ clearMainWindow ();
>++ if not (Prefs.profileUnchanged ()) then loadProfile n true
>++ else Uicommon.refreshConnection ~displayWaitMessage ~termInteract
>++ in
>++
>++ let detectCmd () =
>++ getLock detectUpdatesAndReconcile;
>++ updateDetails ();
>++ if Prefs.read Globals.batch then begin
>++ Prefs.set Globals.batch false; synchronize()
>++ end
>++ in
>++(* actionBar#insert_space ();*)
>++ grAdd grRescan
>++ (insert_button actionBar ~text:"Rescan"
>++ ~stock:`REFRESH
>++ ~tooltip:"Check for updates"
>++ ~callback: (fun () -> reloadProfile(); detectCmd()) ());
>++
>++ (*********************************************************************
>++ Profile change button
>++ *********************************************************************)
>++ actionBar#insert (GButton.separator_tool_item ());
>++ let profileChange _ =
>++ match getProfile false with
>++ None -> ()
>++ | Some p -> clearMainWindow (); loadProfile p false; detectCmd ()
>++ in
>++ grAdd grRescan (insert_button actionBar ~text:"Change Profile"
>++ ~stock:`OPEN
>++ ~tooltip:"Select a different profile"
>++ ~callback:profileChange ());
>++
>++ (*********************************************************************
>++ Keyboard commands
>++ *********************************************************************)
>++ ignore
>++ (mainWindow#event#connect#key_press ~callback:
>++ begin fun ev ->
>++ let key = GdkEvent.Key.keyval ev in
>++ if key = GdkKeysyms._Left then begin
>++ leftAction (); GtkSignal.stop_emit (); true
>++ end else if key = GdkKeysyms._Right then begin
>++ rightAction (); GtkSignal.stop_emit (); true
>++ end else
>++ false
>++ end);
>++
>++ (*********************************************************************
>++ Action menu
>++ *********************************************************************)
>++ let buildActionMenu init =
>++ let withDelayedUpdates f x =
>++ delayUpdates := true;
>++ f x;
>++ delayUpdates := false;
>++ updateDetails () in
>++ let actionMenu = replace_submenu "_Actions" actionItem in
>++ grAdd grRescan
>++ (actionMenu#add_image_item
>++ ~callback:(fun _ -> withDelayedUpdates mainWindow#selection#select_all ())
>++ ~image:((GMisc.image ~stock:`SELECT_ALL ~icon_size:`MENU ())#coerce)
>++ ~modi:[`CONTROL] ~key:GdkKeysyms._A
>++ "Select _All");
>++ grAdd grRescan
>++ (actionMenu#add_item
>++ ~callback:(fun _ -> withDelayedUpdates mainWindow#selection#unselect_all ())
>++ ~modi:[`SHIFT; `CONTROL] ~key:GdkKeysyms._A
>++ "_Deselect All");
>++
>++ ignore (actionMenu#add_separator ());
>++
>++ let (loc1, loc2) =
>++ if init then ("", "") else
>++ let (root1,root2) = Globals.roots () in
>++ (root2hostname root1, root2hostname root2)
>++ in
>++ let def_descr = "Left to Right" in
>++ let descr =
>++ if init || loc1 = loc2 then def_descr else
>++ Printf.sprintf "from %s to %s" loc1 loc2 in
>++ let left =
>++ actionMenu#add_image_item ~key:GdkKeysyms._greater ~callback:rightAction
>++ ~image:((GMisc.image ~stock:`GO_FORWARD ~icon_size:`MENU ())#coerce)
>++ ~name:("Propagate " ^ def_descr) ("Propagate " ^ descr) in
>++ grAdd grAction left;
>++ left#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._greater;
>++ left#add_accelerator ~group:accel_group GdkKeysyms._period;
>++
>++ let def_descl = "Right to Left" in
>++ let descl =
>++ if init || loc1 = loc2 then def_descl else
>++ Printf.sprintf "from %s to %s"
>++ (Unicode.protect loc2) (Unicode.protect loc1) in
>++ let right =
>++ actionMenu#add_image_item ~key:GdkKeysyms._less ~callback:leftAction
>++ ~image:((GMisc.image ~stock:`GO_BACK ~icon_size:`MENU ())#coerce)
>++ ~name:("Propagate " ^ def_descl) ("Propagate " ^ descl) in
>++ grAdd grAction right;
>++ right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._less;
>++ right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._comma;
>++
>++ let skip =
>++ actionMenu#add_image_item ~key:GdkKeysyms._slash ~callback:questionAction
>++ ~image:((GMisc.image ~stock:`NO ~icon_size:`MENU ())#coerce)
>++ "Do _Not Propagate Changes" in
>++ grAdd grAction skip;
>++ skip#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._minus;
>++
>++ let merge =
>++ actionMenu#add_image_item ~key:GdkKeysyms._m ~callback:mergeAction
>++ ~image:((GMisc.image ~stock:`ADD ~icon_size:`MENU ())#coerce)
>++ "_Merge the Files" in
>++ grAdd grAction merge;
>++ (* merge#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._m; *)
>++
>++ (* Override actions *)
>++ ignore (actionMenu#add_separator ());
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ ->
>++ Recon.setDirection ri `Replica1ToReplica2 `Prefer))
>++ "Resolve Conflicts in Favor of First Root");
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ ->
>++ Recon.setDirection ri `Replica2ToReplica1 `Prefer))
>++ "Resolve Conflicts in Favor of Second Root");
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ ->
>++ Recon.setDirection ri `Newer `Prefer))
>++ "Resolve Conflicts in Favor of Most Recently Modified");
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ ->
>++ Recon.setDirection ri `Older `Prefer))
>++ "Resolve Conflicts in Favor of Least Recently Modified");
>++ ignore (actionMenu#add_separator ());
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ -> Recon.setDirection ri `Newer `Force))
>++ "Force Newer Files to Replace Older Ones");
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ -> Recon.setDirection ri `Older `Force))
>++ "Force Older Files to Replace Newer Ones");
>++ ignore (actionMenu#add_separator ());
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ -> Recon.revertToDefaultDirection ri))
>++ "_Revert to Unison's Recommendations");
>++ grAdd grAction
>++ (actionMenu#add_item
>++ ~callback:(fun () ->
>++ doAction (fun ri _ -> Recon.setDirection ri `Merge `Force))
>++ "Revert to the Merging Default, if Available");
>++
>++ (* Diff *)
>++ ignore (actionMenu#add_separator ());
>++ grAdd grDiff (actionMenu#add_image_item ~key:GdkKeysyms._d ~callback:diffCmd
>++ ~image:((GMisc.image ~stock:`DIALOG_INFO ~icon_size:`MENU ())#coerce)
>++ "Show _Diffs");
>++
>++ (* Details *)
>++ grAdd grDetail
>++ (actionMenu#add_image_item ~key:GdkKeysyms._i ~callback:showDetCommand
>++ ~image:((GMisc.image ~stock:`INFO ~icon_size:`MENU ())#coerce)
>++ "Detailed _Information")
>++
>++ in
>++ buildActionMenu true;
>++
>++ (*********************************************************************
>++ Synchronization menu
>++ *********************************************************************)
>++
>++ grAdd grGo
>++ (fileMenu#add_image_item ~key:GdkKeysyms._g
>++ ~image:(GMisc.image ~stock:`EXECUTE ~icon_size:`MENU () :> GObj.widget)
>++ ~callback:(fun () -> getLock synchronize)
>++ "_Go");
>++ grAdd grRescan
>++ (fileMenu#add_image_item ~key:GdkKeysyms._r
>++ ~image:(GMisc.image ~stock:`REFRESH ~icon_size:`MENU () :> GObj.widget)
>++ ~callback:(fun () -> reloadProfile(); detectCmd())
>++ "_Rescan");
>++ grAdd grRescan
>++ (fileMenu#add_item ~key:GdkKeysyms._a
>++ ~callback:(fun () ->
>++ reloadProfile();
>++ Prefs.set Globals.batch true;
>++ detectCmd())
>++ "_Detect Updates and Proceed (Without Waiting)");
>++ grAdd grRescan
>++ (fileMenu#add_item ~key:GdkKeysyms._f
>++ ~callback:(
>++ fun () ->
>++ let rec loop i acc =
>++ if i >= Array.length (!theState) then acc else
>++ let notok =
>++ (match !theState.(i).whatHappened with
>++ None-> true
>++ | Some(Util.Failed _, _) -> true
>++ | Some(Util.Succeeded, _) -> false)
>++ || match !theState.(i).ri.replicas with
>++ Problem _ -> true
>++ | Different diff -> isConflict diff.direction in
>++ if notok then loop (i+1) (i::acc)
>++ else loop (i+1) (acc) in
>++ let failedindices = loop 0 [] in
>++ let failedpaths =
>++ Safelist.map (fun i -> !theState.(i).ri.path1) failedindices in
>++ debug (fun()-> Util.msg "Rescaning with paths = %s\n"
>++ (String.concat ", " (Safelist.map
>++ (fun p -> "'"^(Path.toString p)^"'")
>++ failedpaths)));
>++ let paths = Prefs.read Globals.paths in
>++ let confirmBigDeletes = Prefs.read Globals.confirmBigDeletes in
>++ Prefs.set Globals.paths failedpaths;
>++ Prefs.set Globals.confirmBigDeletes false;
>++ (* Modifying global paths does not play well with filesystem
>++ monitoring, so we disable it. *)
>++ unsynchronizedPaths := None;
>++ detectCmd();
>++ Prefs.set Globals.paths paths;
>++ Prefs.set Globals.confirmBigDeletes confirmBigDeletes;
>++ unsynchronizedPaths := None)
>++ "Re_check Unsynchronized Items");
>++
>++ ignore (fileMenu#add_separator ());
>++
>++ grAdd grRescan
>++ (fileMenu#add_image_item ~key:GdkKeysyms._p
>++ ~callback:(fun _ ->
>++ match getProfile false with
>++ None -> ()
>++ | Some(p) -> clearMainWindow (); loadProfile p false; detectCmd ())
>++ ~image:(GMisc.image ~stock:`OPEN ~icon_size:`MENU () :> GObj.widget)
>++ "Change _Profile...");
>++
>++ let fastProf name key =
>++ grAdd grRescan
>++ (fileMenu#add_item ~key:key
>++ ~callback:(fun _ ->
>++ if System.file_exists (Prefs.profilePathname name) then begin
>++ Trace.status ("Loading profile " ^ name);
>++ loadProfile name false; detectCmd ()
>++ end else
>++ Trace.status ("Profile " ^ name ^ " not found"))
>++ ("Select profile " ^ name)) in
>++
>++ let fastKeysyms =
>++ [| GdkKeysyms._0; GdkKeysyms._1; GdkKeysyms._2; GdkKeysyms._3;
>++ GdkKeysyms._4; GdkKeysyms._5; GdkKeysyms._6; GdkKeysyms._7;
>++ GdkKeysyms._8; GdkKeysyms._9 |] in
>++
>++ Array.iteri
>++ (fun i v -> match v with
>++ None -> ()
>++ | Some(profile, info) ->
>++ fastProf profile fastKeysyms.(i))
>++ Uicommon.profileKeymap;
>++
>++ ignore (fileMenu#add_separator ());
>++ ignore (fileMenu#add_item
>++ ~callback:(fun _ -> statWin#show ()) "Show _Statistics");
>++
>++ ignore (fileMenu#add_separator ());
>++ let quit =
>++ fileMenu#add_image_item
>++ ~key:GdkKeysyms._q ~callback:safeExit
>++ ~image:((GMisc.image ~stock:`QUIT ~icon_size:`MENU ())#coerce)
>++ "_Quit"
>++ in
>++ quit#add_accelerator ~group:accel_group ~modi:[`CONTROL] GdkKeysyms._q;
>++
>++ (*********************************************************************
>++ Expert menu
>++ *********************************************************************)
>++ if Prefs.read Uicommon.expert then begin
>++ let (expertMenu, _) = add_submenu "Expert" in
>++
>++ let addDebugToggle modname =
>++ ignore (expertMenu#add_check_item ~active:(Trace.enabled modname)
>++ ~callback:(fun b -> Trace.enable modname b)
>++ ("Debug '" ^ modname ^ "'")) in
>++
>++ addDebugToggle "all";
>++ addDebugToggle "verbose";
>++ addDebugToggle "update";
>++
>++ ignore (expertMenu#add_separator ());
>++ ignore (expertMenu#add_item
>++ ~callback:(fun () ->
>++ Printf.fprintf stderr "\nGC stats now:\n";
>++ Gc.print_stat stderr;
>++ Printf.fprintf stderr "\nAfter major collection:\n";
>++ Gc.full_major(); Gc.print_stat stderr;
>++ flush stderr)
>++ "Show memory/GC stats")
>++ end;
>++
>++ (*********************************************************************
>++ Finish up
>++ *********************************************************************)
>++ grDisactivateAll ();
>++
>++ updateFromProfile :=
>++ (fun () ->
>++ displayNewProfileLabel ();
>++ setMainWindowColumnHeaders (Uicommon.roots2string ());
>++ buildActionMenu false);
>++
>++
>++ ignore (toplevelWindow#event#connect#delete ~callback:
>++ (fun _ -> safeExit (); true));
>++ toplevelWindow#show ();
>++ fun () ->
>++ !updateFromProfile ();
>++ mainWindow#misc#grab_focus ();
>++ detectCmd ()
>++
>++
>++(*********************************************************************
>++ STARTUP
>++ *********************************************************************)
>++
>++let start _ =
>++ begin try
>++ (* Initialize the GTK library *)
>++ ignore (GMain.Main.init ());
>++
>++ Util.warnPrinter :=
>++ Some (fun msg -> warnBox ~parent:(toplevelWindow ()) "Warning" msg);
>++
>++ GtkSignal.user_handler :=
>++ (fun exn ->
>++ match exn with
>++ Util.Transient(s) | Util.Fatal(s) -> fatalError s
>++ | exn -> fatalError (Uicommon.exn2string exn));
>++
>++ (* Ask the Remote module to call us back at regular intervals during
>++ long network operations. *)
>++ let rec tick () =
>++ gtk_sync true;
>++ Lwt_unix.sleep 0.05 >>= tick
>++ in
>++ ignore_result (tick ());
>++
>++ let prepDebug () =
>++ if Sys.os_type = "Win32" then
>++ (* As a side-effect, this allocates a console if the process doesn't
>++ have one already. This call is here only for the side-effect,
>++ because debugging output is produced on stderr and the GUI will
>++ crash if there is no stderr. *)
>++ try ignore (System.terminalStateFunctions ())
>++ with Unix.Unix_error _ -> ()
>++ in
>++
>++ Os.createUnisonDir();
>++ Uicommon.scanProfiles();
>++ let detectCmd = createToplevelWindow() in
>++
>++ Uicommon.uiInit
>++ ~prepDebug
>++ ~reportError:fatalError
>++ ~tryAgainOrQuit
>++ ~displayWaitMessage
>++ ~getProfile:(fun () -> getProfile true)
>++ ~getFirstRoot
>++ ~getSecondRoot
>++ ~termInteract
>++ ();
>++ detectCmd ();
>++
>++ (* Display the ui *)
>++(*JV: not useful, as Unison does not handle any signal
>++ ignore (GMain.Timeout.add 500 (fun _ -> true));
>++ (* Hack: this allows signals such as SIGINT to be
>++ handled even when Gtk is waiting for events *)
>++*)
>++ GMain.Main.main ()
>++ with
>++ Util.Transient(s) | Util.Fatal(s) -> fatalError s
>++ | exn -> fatalError (Uicommon.exn2string exn)
>++ end
>++
>++end (* module Private *)
>++
>++
>++(*********************************************************************
>++ UI SELECTION
>++ *********************************************************************)
>++
>++module Body : Uicommon.UI = struct
>++
>++let start = function
>++ Uicommon.Text -> Uitext.Body.start Uicommon.Text
>++ | Uicommon.Graphic ->
>++ let displayAvailable =
>++ Util.osType = `Win32
>++ ||
>++ try System.getenv "DISPLAY" <> "" with Not_found -> false
>++ in
>++ if displayAvailable then Private.start Uicommon.Graphic
>++ else
>++ Util.warn "DISPLAY not set or empty; starting the Text UI\n";
>++ Uitext.Body.start Uicommon.Text
>++
>++let defaultUi = Uicommon.Graphic
>++
>++end (* module Body *)
>+Index: unison-2.51.5/src/uigtk2.mli
>+===================================================================
>+--- unison-2.51.5.orig/src/uigtk2.mli
>++++ /dev/null
>+@@ -1,4 +0,0 @@
>+-(* Unison file synchronizer: src/uigtk2.mli *)
>+-(* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *)
>+-
>+-module Body : Uicommon.UI
>+Index: unison-2.51.5/src/uigtk3.mli
>+===================================================================
>+--- /dev/null
>++++ unison-2.51.5/src/uigtk3.mli
>+@@ -0,0 +1,4 @@
>++(* Unison file synchronizer: src/uigtk3.mli *)
>++(* Copyright 1999-2020, Benjamin C. Pierce (see COPYING for details) *)
>++
>++module Body : Uicommon.UI
>diff --git a/net-misc/unison/unison-2.51.5.ebuild b/net-misc/unison/unison-2.51.5.ebuild
>index f68427249b7..f1aeb6e0265 100644
>--- a/net-misc/unison/unison-2.51.5.ebuild
>+++ b/net-misc/unison/unison-2.51.5.ebuild
>@@ -18,13 +18,21 @@ BDEPEND="dev-lang/ocaml:=[ocamlopt?]
> 	doc? ( app-text/dvipsk
> 		app-text/ghostscript-gpl
> 		dev-texlive/texlive-latex )"
>-DEPEND="gtk? ( dev-ml/lablgtk:2=[ocamlopt?] )"
>-RDEPEND="gtk? ( dev-ml/lablgtk:2=[ocamlopt?]
>+DEPEND="gtk? ( dev-ml/lablgtk:3=[ocamlopt?] )"
>+RDEPEND="gtk? ( dev-ml/lablgtk:3=[ocamlopt?]
> 	|| ( net-misc/x11-ssh-askpass net-misc/ssh-askpass-fullscreen ) )
> 	>=app-eselect/eselect-unison-0.4"
> 
> DOCS=( CONTRIB INSTALL NEWS README ROADMAP.txt TODO.txt )
> 
>+PATCHES=(
>+	"${FILESDIR}"/62272e8f203f32510dfa292c99408928da974f4e.patch
>+	"${FILESDIR}"/393c03565399de3a8e02e105eb2b8ee8cc620f19.patch
>+	"${FILESDIR}"/9626711a6c6a4da4fb73fd6b81e1023710ee1266.patch
>+	"${FILESDIR}"/d0b45f073c0899d7e743582bdcad858bd2c69ea1.patch
>+	"${FILESDIR}"/e05957692b1e21517708e4252f3b0e22cb1ac206.patch
>+)
>+
> src_prepare() {
> 	default
> 	# https://github.com/bcpierce00/unison/issues/416
>@@ -45,7 +53,7 @@ src_compile() {
> 	fi
> 
> 	if use gtk; then
>-		myconf+=( UISTYLE=gtk2 )
>+		myconf+=( UISTYLE=gtk3 )
> 	else
> 		myconf+=( UISTYLE=text )
> 	fi
>-- 
>2.35.1
>

Actions: View

Attachments on bug 769341: 743826 | 743829 | 743832 | 743835 | 743838 | 743841 | 765681 | 765682 | 765683 | 765684 | 765685 | 765686 | 765714