From 5046106f2f9aa2a907290ad13aae755bd91c40dd Mon Sep 17 00:00:00 2001 From: "Dr. Bernd Feige" 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?= +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 . +-*) +- +- +-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 . +-*) +- +- +-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 . ++*) ++ ++ ++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 . +-*) +- +- +-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="/") +- ?(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]+\\);" +-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" tag (Str.matched_group 2 s) tag +- with Exit -> +- Str.matched_group 0 s) >>> +- Str.global_replace verbRe "\\1" >>> +- Str.global_replace argRe "\\1" >>> +- Str.global_replace textttRe "\\1" >>> +- 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 . ++*) ++ ++ ++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="/") ++ ?(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]+\\);" ++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" tag (Str.matched_group 2 s) tag ++ with Exit -> ++ Str.matched_group 0 s) >>> ++ Str.global_replace verbRe "\\1" >>> ++ Str.global_replace argRe "\\1" >>> ++ Str.global_replace textttRe "\\1" >>> ++ 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