Go to:
Gentoo Home
Documentation
Forums
Lists
Bugs
Planet
Store
Wiki
Get Gentoo!
Gentoo's Bugzilla – Attachment 765686 Details for
Bug 769341
net-misc/unison[gtk] depends on dev-ml/lablgtk:2
Home
|
New
–
[Ex]
|
Browse
|
Search
|
Privacy Policy
|
[?]
|
Reports
|
Requests
|
Help
|
New Account
|
Log In
[x]
|
Forgot Password
Login:
[x]
[patch]
uigtk2 -> uigtk3
e05957692b1e21517708e4252f3b0e22cb1ac206.patch (text/plain), 321.54 KB, created by
Bernd Feige
on 2022-02-22 21:34:08 UTC
(
hide
)
Description:
uigtk2 -> uigtk3
Filename:
MIME Type:
Creator:
Bernd Feige
Created:
2022-02-22 21:34:08 UTC
Size:
321.54 KB
patch
obsolete
>From e05957692b1e21517708e4252f3b0e22cb1ac206 Mon Sep 17 00:00:00 2001 >From: =?UTF-8?q?T=C3=B5ivo=20Leedj=C3=A4rv?= > <69477666+tleedjarv@users.noreply.github.com> >Date: Wed, 14 Jul 2021 20:38:12 +0200 >Subject: [PATCH] uigtk2 -> uigtk3 > >--- > .github/workflows/CICD.yml | 4 ++-- > src/.depend | 18 +++++++++--------- > src/Makefile.OCaml | 20 ++++++++++---------- > src/dune | 8 ++++---- > src/{linkgtk2.ml => linkgtk3.ml} | 4 ++-- > src/{uigtk2.ml => uigtk3.ml} | 2 +- > src/{uigtk2.mli => uigtk3.mli} | 2 +- > 7 files changed, 29 insertions(+), 29 deletions(-) > rename src/{linkgtk2.ml => linkgtk3.ml} (88%) > rename src/{uigtk2.ml => uigtk3.ml} (99%) > rename src/{uigtk2.mli => uigtk3.mli} (67%) > >Index: unison-2.51.5/.github/workflows/CICD.yml >=================================================================== >--- unison-2.51.5.orig/.github/workflows/CICD.yml >+++ unison-2.51.5/.github/workflows/CICD.yml >@@ -176,11 +176,11 @@ jobs: > - if: steps.vars.outputs.STATIC != 'true' ## unable to build static gtk for linux or windows/Cygwin MinGW platforms > shell: bash > run: | >- opam exec -- make src OSTYPE=$OSTYPE UISTYLE=gtk2 STATIC=${{ steps.vars.outputs.STATIC }} >+ opam exec -- make src OSTYPE=$OSTYPE UISTYLE=gtk3 STATIC=${{ steps.vars.outputs.STATIC }} > # stage > # * copy only main/first project binary > project_exe_stem=${PROJECT_EXES%% *} >- cp "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" "${{ steps.vars.outputs.PKG_DIR }}/bin/${project_exe_stem}-gtk2${{ steps.vars.outputs.EXE_suffix }}" >+ cp "src/${project_exe_stem}${{ steps.vars.outputs.EXE_suffix }}" "${{ steps.vars.outputs.PKG_DIR }}/bin/${project_exe_stem}-gtk3${{ steps.vars.outputs.EXE_suffix }}" > > - uses: actions/upload-artifact@v2 > with: >Index: unison-2.51.5/src/.depend >=================================================================== >--- unison-2.51.5.orig/src/.depend >+++ unison-2.51.5/src/.depend >@@ -514,11 +514,11 @@ globals.cmi : \ > path.cmi \ > lwt/lwt.cmi \ > common.cmi >-linkgtk2.cmo : \ >- uigtk2.cmi \ >+linkgtk3.cmo : \ >+ uigtk3.cmi \ > main.cmo >-linkgtk2.cmx : \ >- uigtk2.cmx \ >+linkgtk3.cmx : \ >+ uigtk3.cmx \ > main.cmx > linktext.cmo : \ > uitext.cmi \ >@@ -1209,7 +1209,7 @@ uicommon.cmi : \ > path.cmi \ > lwt/lwt.cmi \ > common.cmi >-uigtk2.cmo : \ >+uigtk3.cmo : \ > uutil.cmi \ > ubase/util.cmi \ > update.cmi \ >@@ -1235,8 +1235,8 @@ uigtk2.cmo : \ > common.cmi \ > clroot.cmi \ > case.cmi \ >- uigtk2.cmi >-uigtk2.cmx : \ >+ uigtk3.cmi >+uigtk3.cmx : \ > uutil.cmx \ > ubase/util.cmx \ > update.cmx \ >@@ -1262,8 +1262,8 @@ uigtk2.cmx : \ > common.cmx \ > clroot.cmx \ > case.cmx \ >- uigtk2.cmi >-uigtk2.cmi : \ >+ uigtk3.cmi >+uigtk3.cmi : \ > uicommon.cmi > uimacbridge.cmo : \ > xferhint.cmi \ >Index: unison-2.51.5/src/Makefile.OCaml >=================================================================== >--- unison-2.51.5.orig/src/Makefile.OCaml >+++ unison-2.51.5/src/Makefile.OCaml >@@ -69,23 +69,23 @@ OCAMLLIBDIR=$(shell ocamlc -v | tail -1 > # User interface style: > # Legal values are > # UISTYLE=text >-# UISTYLE=gtk2 >+# UISTYLE=gtk3 > # UISTYLE=mac > # > # This should be set to an appropriate value automatically, depending > # on whether the lablgtk library is available >-LABLGTK2LIB=$(OCAMLLIBDIR)/lablgtk3 >+LABLGTK3LIB=$(OCAMLLIBDIR)/lablgtk3 > ##BCP [3/2007]: Removed temporarily, since the OSX UI is not working well > ## at the moment and we don't want to confuse people by building it by default > ifeq ($(OSARCH),osx) > UISTYLE=mac > else >- ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB)) >- UISTYLE=gtk2 >+ ifeq ($(wildcard $(LABLGTK3LIB)),$(LABLGTK3LIB)) >+ UISTYLE=gtk3 > else >- LABLGTK2LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk3) >- ifeq ($(wildcard $(LABLGTK2LIB)),$(LABLGTK2LIB)) >- UISTYLE=gtk2 >+ LABLGTK3LIB=$(abspath $(OCAMLLIBDIR)/../lablgtk3) >+ ifeq ($(wildcard $(LABLGTK3LIB)),$(LABLGTK3LIB)) >+ UISTYLE=gtk3 > else > UISTYLE=text > endif >@@ -271,16 +271,16 @@ ifeq ($(OSARCH), win32) > endif > endif > >-# Gtk2 GUI >+# Gtk3 GUI > OCAMLFIND := $(shell command -v ocamlfind 2> /dev/null) > >-ifeq ($(UISTYLE), gtk2) >+ifeq ($(UISTYLE), gtk3) > ifndef OCAMLFIND > CAMLFLAGS+=-I +lablgtk3 > else > CAMLFLAGS+=$(shell $(OCAMLFIND) query -i-format lablgtk3 ) > endif >- OCAMLOBJS+=pixmaps.cmo uigtk2.cmo linkgtk2.cmo >+ OCAMLOBJS+=pixmaps.cmo uigtk3.cmo linkgtk3.cmo > OCAMLLIBS+=lablgtk3.cma > endif > >Index: unison-2.51.5/src/dune >=================================================================== >--- unison-2.51.5.orig/src/dune >+++ unison-2.51.5/src/dune >@@ -1,7 +1,7 @@ > (library > (name unison_lib) > (wrapped false) >- (modules :standard \ linktext linkgtk2 uigtk2 uimacbridge uimacbridgenew test) >+ (modules :standard \ linktext linkgtk3 uigtk3 uimacbridge uimacbridgenew test) > (modules_without_implementation ui) > (flags :standard > -w -3-6-9-10-26-27-32-34-35-38-39-50-52 >@@ -22,8 +22,8 @@ > (libraries unison_lib)) > > (executable >- (name linkgtk2) >- (public_name unison-gtk2) >+ (name linkgtk3) >+ (public_name unison-gtk3) > (flags :standard -w -3-6-9-27-32-52) >- (modules linkgtk2 uigtk2) >+ (modules linkgtk3 uigtk3) > (libraries threads unison_lib lablgtk3)) >Index: unison-2.51.5/src/linkgtk2.ml >=================================================================== >--- unison-2.51.5.orig/src/linkgtk2.ml >+++ /dev/null >@@ -1,19 +0,0 @@ >-(* Unison file synchronizer: src/linkgtk2.ml *) >-(* Copyright 1999-2020, Benjamin C. Pierce >- >- This program is free software: you can redistribute it and/or modify >- it under the terms of the GNU General Public License as published by >- the Free Software Foundation, either version 3 of the License, or >- (at your option) any later version. >- >- This program is distributed in the hope that it will be useful, >- but WITHOUT ANY WARRANTY; without even the implied warranty of >- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the >- GNU General Public License for more details. >- >- You should have received a copy of the GNU General Public License >- along with this program. If not, see <http://www.gnu.org/licenses/>. >-*) >- >- >-module TopLevel = Main.Body(Uigtk2.Body) >Index: unison-2.51.5/src/linkgtk3.ml >=================================================================== >--- /dev/null >+++ unison-2.51.5/src/linkgtk3.ml >@@ -0,0 +1,19 @@ >+(* Unison file synchronizer: src/linkgtk3.ml *) >+(* Copyright 1999-2020, Benjamin C. Pierce >+ >+ This program is free software: you can redistribute it and/or modify >+ it under the terms of the GNU General Public License as published by >+ the Free Software Foundation, either version 3 of the License, or >+ (at your option) any later version. >+ >+ This program is distributed in the hope that it will be useful, >+ but WITHOUT ANY WARRANTY; without even the implied warranty of >+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the >+ GNU General Public License for more details. >+ >+ You should have received a copy of the GNU General Public License >+ along with this program. If not, see <http://www.gnu.org/licenses/>. >+*) >+ >+ >+module TopLevel = Main.Body(Uigtk3.Body) >Index: unison-2.51.5/src/uigtk2.ml >=================================================================== >--- unison-2.51.5.orig/src/uigtk2.ml >+++ /dev/null >@@ -1,4239 +0,0 @@ >-(* Unison file synchronizer: src/uigtk2.ml *) >-(* Copyright 1999-2020, Benjamin C. Pierce >- >- This program is free software: you can redistribute it and/or modify >- it under the terms of the GNU General Public License as published by >- the Free Software Foundation, either version 3 of the License, or >- (at your option) any later version. >- >- This program is distributed in the hope that it will be useful, >- but WITHOUT ANY WARRANTY; without even the implied warranty of >- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the >- GNU General Public License for more details. >- >- You should have received a copy of the GNU General Public License >- along with this program. If not, see <http://www.gnu.org/licenses/>. >-*) >- >- >-open Common >-open Lwt >- >-module Private = struct >- >-let debug = Trace.debug "ui" >- >-let myNameCapitalized = String.capitalize_ascii Uutil.myName >- >-(********************************************************************** >- LOW-LEVEL STUFF >- **********************************************************************) >- >-(********************************************************************** >- Some message strings (build them here because they look ugly in the >- middle of other code. >- **********************************************************************) >- >-let tryAgainMessage = >- Printf.sprintf >-"You can use %s to synchronize a local directory with another local directory, >-or with a remote directory. >- >-Please enter the first (local) directory that you want to synchronize." >-myNameCapitalized >- >-(* ---- *) >- >-let helpmessage = Printf.sprintf >-"%s can synchronize a local directory with another local directory, or with >-a directory on a remote machine. >- >-To synchronize with a local directory, just enter the file name. >- >-To synchronize with a remote directory, you must first choose a protocol >-that %s will use to connect to the remote machine. Each protocol has >-different requirements: >- >-1) To synchronize using SSH, there must be an SSH client installed on >-this machine and an SSH server installed on the remote machine. You >-must enter the host to connect to, a user name (if different from >-your user name on this machine), and the directory on the remote machine >-(relative to your home directory on that machine). >- >-2) To synchronize using RSH, there must be an RSH client installed on >-this machine and an RSH server installed on the remote machine. You >-must enter the host to connect to, a user name (if different from >-your user name on this machine), and the directory on the remote machine >-(relative to your home directory on that machine). >- >-3) To synchronize using %s's socket protocol, there must be a %s >-server running on the remote machine, listening to the port that you >-specify here. (Use \"%s -socket xxx\" on the remote machine to >-start the %s server.) You must enter the host, port, and the directory >-on the remote machine (relative to the working directory of the >-%s server running on that machine)." >-myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized >- >-(********************************************************************** >- Font preferences >- **********************************************************************) >- >-let fontMonospace = lazy (Pango.Font.from_string "monospace") >-let fontBold = lazy (Pango.Font.from_string "bold") >-let fontItalic = lazy (Pango.Font.from_string "italic") >- >-(********************************************************************** >- Unison icon >- **********************************************************************) >- >-(* This does not work with the current version of Lablgtk, due to a bug >-let icon = >- GdkPixbuf.from_data ~width:48 ~height:48 ~has_alpha:true >- (Gpointer.region_of_bytes Pixmaps.icon_data) >-*) >-let icon = >- let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in >- let pxs = GdkPixbuf.get_pixels p in >- (* This little hack is here to support compiling with lablgtk versions both >- < 2.18.6 and >= 2.18.6 *) >- String.iteri (fun i c -> Gpointer.set_byte pxs ~pos:i (Char.code c)) Pixmaps.icon_data; >- p >- >-let leftPtrWatch = >- lazy (Gdk.Cursor.create `WATCH) >- >-let make_busy w = >- if Util.osType <> `Win32 then >- Gdk.Window.set_cursor w#misc#window (Lazy.force leftPtrWatch) >-let make_interactive w = >- if Util.osType <> `Win32 then >- (* HACK: setting the cursor to NULL restore the default cursor *) >- Gdk.Window.set_cursor w#misc#window (Obj.magic Gpointer.boxed_null) >- >-(********************************************************************* >- UI state variables >- *********************************************************************) >- >-type stateItem = { mutable ri : reconItem; >- mutable bytesTransferred : Uutil.Filesize.t; >- mutable bytesToTransfer : Uutil.Filesize.t; >- mutable whatHappened : (Util.confirmation * string option) option} >-let theState = ref [||] >-let unsynchronizedPaths = ref None >- >-(* ---- *) >- >-let theToplevelWindow = ref None >-let setToplevelWindow w = theToplevelWindow := Some w >-let toplevelWindow () = >- match !theToplevelWindow with >- Some w -> w >- | None -> raise (Util.Fatal "Main window not initialized; check your DISPLAY setup") >- >-(********************************************************************* >- Lock management >- *********************************************************************) >- >-let busy = ref false >- >-let getLock f = >- if !busy then >- Trace.status "Synchronizer is busy, please wait.." >- else begin >- busy := true; f (); busy := false >- end >- >-(********************************************************************** >- Miscellaneous >- **********************************************************************) >- >-let sync_action = ref None >- >-let last = ref (0.) >- >-let gtk_sync forced = >- let t = Unix.gettimeofday () in >- if !last = 0. || forced || t -. !last > 0.05 then begin >- last := t; >- begin match !sync_action with >- Some f -> f () >- | None -> () >- end; >- while Glib.Main.iteration false do () done >- end >- >-(********************************************************************** >- CHARACTER SET TRANSCODING >-***********************************************************************) >- >-(* Transcodage from Microsoft Windows Codepage 1252 to Unicode *) >- >-(* Unison currently uses the "ASCII" Windows filesystem API. With >- this API, filenames are encoded using a proprietary character >- encoding. This encoding depends on the Windows setup, but in >- Western Europe, the Windows Codepage 1252 is usually used. >- GTK, on the other hand, uses the UTF-8 encoding. This code perform >- the translation from Codepage 1252 to UTF-8. A call to [transcode] >- should be wrapped around every string below that might contain >- non-ASCII characters. *) >- >-let code = >- [| 0x0020; 0x0001; 0x0002; 0x0003; 0x0004; 0x0005; 0x0006; 0x0007; >- 0x0008; 0x0009; 0x000A; 0x000B; 0x000C; 0x000D; 0x000E; 0x000F; >- 0x0010; 0x0011; 0x0012; 0x0013; 0x0014; 0x0015; 0x0016; 0x0017; >- 0x0018; 0x0019; 0x001A; 0x001B; 0x001C; 0x001D; 0x001E; 0x001F; >- 0x0020; 0x0021; 0x0022; 0x0023; 0x0024; 0x0025; 0x0026; 0x0027; >- 0x0028; 0x0029; 0x002A; 0x002B; 0x002C; 0x002D; 0x002E; 0x002F; >- 0x0030; 0x0031; 0x0032; 0x0033; 0x0034; 0x0035; 0x0036; 0x0037; >- 0x0038; 0x0039; 0x003A; 0x003B; 0x003C; 0x003D; 0x003E; 0x003F; >- 0x0040; 0x0041; 0x0042; 0x0043; 0x0044; 0x0045; 0x0046; 0x0047; >- 0x0048; 0x0049; 0x004A; 0x004B; 0x004C; 0x004D; 0x004E; 0x004F; >- 0x0050; 0x0051; 0x0052; 0x0053; 0x0054; 0x0055; 0x0056; 0x0057; >- 0x0058; 0x0059; 0x005A; 0x005B; 0x005C; 0x005D; 0x005E; 0x005F; >- 0x0060; 0x0061; 0x0062; 0x0063; 0x0064; 0x0065; 0x0066; 0x0067; >- 0x0068; 0x0069; 0x006A; 0x006B; 0x006C; 0x006D; 0x006E; 0x006F; >- 0x0070; 0x0071; 0x0072; 0x0073; 0x0074; 0x0075; 0x0076; 0x0077; >- 0x0078; 0x0079; 0x007A; 0x007B; 0x007C; 0x007D; 0x007E; 0x007F; >- 0x20AC; 0x1234; 0x201A; 0x0192; 0x201E; 0x2026; 0x2020; 0x2021; >- 0x02C6; 0x2030; 0x0160; 0x2039; 0x0152; 0x1234; 0x017D; 0x1234; >- 0x1234; 0x2018; 0x2019; 0x201C; 0x201D; 0x2022; 0x2013; 0x2014; >- 0x02DC; 0x2122; 0x0161; 0x203A; 0x0153; 0x1234; 0x017E; 0x0178; >- 0x00A0; 0x00A1; 0x00A2; 0x00A3; 0x00A4; 0x00A5; 0x00A6; 0x00A7; >- 0x00A8; 0x00A9; 0x00AA; 0x00AB; 0x00AC; 0x00AD; 0x00AE; 0x00AF; >- 0x00B0; 0x00B1; 0x00B2; 0x00B3; 0x00B4; 0x00B5; 0x00B6; 0x00B7; >- 0x00B8; 0x00B9; 0x00BA; 0x00BB; 0x00BC; 0x00BD; 0x00BE; 0x00BF; >- 0x00C0; 0x00C1; 0x00C2; 0x00C3; 0x00C4; 0x00C5; 0x00C6; 0x00C7; >- 0x00C8; 0x00C9; 0x00CA; 0x00CB; 0x00CC; 0x00CD; 0x00CE; 0x00CF; >- 0x00D0; 0x00D1; 0x00D2; 0x00D3; 0x00D4; 0x00D5; 0x00D6; 0x00D7; >- 0x00D8; 0x00D9; 0x00DA; 0x00DB; 0x00DC; 0x00DD; 0x00DE; 0x00DF; >- 0x00E0; 0x00E1; 0x00E2; 0x00E3; 0x00E4; 0x00E5; 0x00E6; 0x00E7; >- 0x00E8; 0x00E9; 0x00EA; 0x00EB; 0x00EC; 0x00ED; 0x00EE; 0x00EF; >- 0x00F0; 0x00F1; 0x00F2; 0x00F3; 0x00F4; 0x00F5; 0x00F6; 0x00F7; >- 0x00F8; 0x00F9; 0x00FA; 0x00FB; 0x00FC; 0x00FD; 0x00FE; 0x00FF |] >- >-let rec transcodeRec buf s i l = >- if i < l then begin >- let c = code.(Char.code s.[i]) in >- if c < 0x80 then >- Buffer.add_char buf (Char.chr c) >- else if c < 0x800 then begin >- Buffer.add_char buf (Char.chr (c lsr 6 + 0xC0)); >- Buffer.add_char buf (Char.chr (c land 0x3f + 0x80)) >- end else if c < 0x10000 then begin >- Buffer.add_char buf (Char.chr (c lsr 12 + 0xE0)); >- Buffer.add_char buf (Char.chr ((c lsr 6) land 0x3f + 0x80)); >- Buffer.add_char buf (Char.chr (c land 0x3f + 0x80)) >- end; >- transcodeRec buf s (i + 1) l >- end >- >-let transcodeDoc s = >- let buf = Buffer.create 1024 in >- transcodeRec buf s 0 (String.length s); >- Buffer.contents buf >- >-(****) >- >-let escapeMarkup s = Glib.Markup.escape_text s >- >-let transcodeFilename s = >- if Prefs.read Case.unicodeEncoding then >- Unicode.protect s >- else if Util.osType = `Win32 then transcodeDoc s else >- try >- Glib.Convert.filename_to_utf8 s >- with Glib.Convert.Error _ -> >- Unicode.protect s >- >-let transcode s = >- if Prefs.read Case.unicodeEncoding then >- Unicode.protect s >- else >- try >- Glib.Convert.locale_to_utf8 s >- with Glib.Convert.Error _ -> >- Unicode.protect s >- >-(********************************************************************** >- USEFUL LOW-LEVEL WIDGETS >- **********************************************************************) >- >-class scrolled_text ?editable ?shadow_type ?word_wrap >- ~width ~height ?packing ?show >- () = >- let sw = >- GBin.scrolled_window ?packing ~show:false >- ?shadow_type ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () >- in >- let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in >- object >- inherit GObj.widget_full sw#as_widget >- method text = text >- method insert s = text#buffer#set_text s; >- method show () = sw#misc#show () >- initializer >- text#misc#set_size_chars ~height ~width (); >- if show <> Some false then sw#misc#show () >- end >- >-(* ------ *) >- >-(* Display a message in a window and wait for the user >- to hit the button. *) >-let okBox ~parent ~title ~typ ~message = >- let t = >- GWindow.message_dialog >- ~parent ~title ~message_type:typ ~message ~modal:true >- ~buttons:GWindow.Buttons.ok () in >- ignore (t#run ()); t#destroy () >- >-(* ------ *) >- >-let primaryText msg = >- Printf.sprintf "<span weight=\"bold\" size=\"larger\">%s</span>" >- (escapeMarkup msg) >- >-(* twoBox: Display a message in a window and wait for the user >- to hit one of two buttons. Return true if the first button is >- chosen, false if the second button is chosen. *) >-let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message = >- let t = >- GWindow.dialog ~parent ~border_width:6 ~modal:true >- ~resizable:false () in >- t#vbox#set_spacing 12; >- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >- ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG >- ~yalign:0. ~packing:h1#pack ()); >- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >- ignore (GMisc.label >- ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message) >- ~selectable:true ~yalign:0. ~packing:v1#add ()); >- t#add_button_stock bstock `NO; >- t#add_button_stock astock `YES; >- t#set_default_response `NO; >- t#show(); >- let res = t#run () in >- t#destroy (); >- res = `YES >- >-(* ------ *) >- >-(* Avoid recursive invocations of the function below (a window receives >- delete events even when it is not sensitive) *) >-let inExit = ref false >- >-let doExit () = Lwt_unix.run (Update.unlockArchives ()); exit 0 >- >-let safeExit () = >- if not !inExit then begin >- inExit := true; >- if not !busy then exit 0 else >- if twoBox ~parent:(toplevelWindow ()) ~title:"Premature exit" >- ~astock:`YES ~bstock:`NO >- "Unison is working, exit anyway ?" >- then exit 0; >- inExit := false >- end >- >-(* ------ *) >- >-(* warnBox: Display a warning message in a window and wait (unless >- we're in batch mode) for the user to hit "OK" or "Exit". *) >-let warnBox ~parent title message = >- let message = transcode message in >- if Prefs.read Globals.batch then begin >- (* In batch mode, just pop up a window and go ahead *) >- let t = >- GWindow.dialog ~parent >- ~border_width:6 ~modal:true ~resizable:false () in >- t#vbox#set_spacing 12; >- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >- ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG >- ~yalign:0. ~packing:h1#pack ()); >- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >- ignore (GMisc.label ~markup:(primaryText title ^ "\n\n" ^ >- escapeMarkup message) >- ~selectable:true ~yalign:0. ~packing:v1#add ()); >- t#add_button_stock `CLOSE `CLOSE; >- t#set_default_response `CLOSE; >- ignore (t#connect#response ~callback:(fun _ -> t#destroy ())); >- t#show () >- end else begin >- inExit := true; >- let ok = >- twoBox ~parent:(toplevelWindow ()) ~title ~astock:`OK ~bstock:`QUIT >- message in >- if not(ok) then doExit (); >- inExit := false >- end >- >-(****) >- >-let accel_paths = Hashtbl.create 17 >-let underscore_re = Str.regexp_string "_" >-class ['a] gMenuFactory >- ?(accel_group=GtkData.AccelGroup.create ()) >- ?(accel_path="<DEFAULT ROOT>/") >- ?(accel_modi=[`CONTROL]) >- ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) = >- object (self) >- val menu_shell : #GMenu.menu_shell = menu_shell >- val group = accel_group >- val m = accel_modi >- val flags = (accel_flags:Gtk.Tags.accel_flag list) >- val accel_path = accel_path >- method menu = menu_shell >- method accel_group = group >- method accel_path = accel_path >- method private bind >- ?(modi=m) ?key ?callback label ?(name=label) (item : GMenu.menu_item) = >- menu_shell#append item; >- let accel_path = accel_path ^ name in >- let accel_path = Str.global_replace underscore_re "" accel_path in >- (* Default accel path value *) >- if not (Hashtbl.mem accel_paths accel_path) then begin >- Hashtbl.add accel_paths accel_path (); >- GtkData.AccelMap.add_entry accel_path ?key ~modi >- end; >- (* Register this accel path *) >- GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group; >- Gaux.may callback ~f:(fun callback -> item#connect#activate ~callback) >- method add_item ?key ?modi ?callback ?submenu label = >- let item = GMenu.menu_item ~use_mnemonic:true ~label () in >- self#bind ?modi ?key ?callback label item; >- Gaux.may (submenu : GMenu.menu option) ~f:item#set_submenu; >- item >- method add_image_item ?(image : GObj.widget option) >- ?modi ?key ?callback ?stock ?name label = >- (* GTK 3 does not provide image menu items (there is a way to >- manually create a workaround but that does not work with >- lablgtk. Let's create a regular menu item instead. *) >- let item = >- GMenu.menu_item ~use_mnemonic:true ~label () in >- match stock with >- | None -> >- self#bind ?modi ?key ?callback label ?name item; >- item >- | Some s -> >- try >- let st = GtkStock.Item.lookup s in >- self#bind >- ?modi ?key:(if st.GtkStock.keyval=0 then key else None) >- ?callback label ?name item; >- item >- with Not_found -> item >- >- method add_check_item ?active ?modi ?key ?callback label = >- let item = GMenu.check_menu_item ~label ~use_mnemonic:true ?active () in >- self#bind label ?modi ?key >- ?callback:(Gaux.may_map callback ~f:(fun f () -> f item#active)) >- (item : GMenu.check_menu_item :> GMenu.menu_item); >- item >- method add_separator () = GMenu.separator_item ~packing:menu_shell#append () >- method add_submenu label = >- let item = GMenu.menu_item ~use_mnemonic:true ~label () in >- self#bind label item; >- (GMenu.menu ~packing:item#set_submenu (), item) >- method replace_submenu (item : GMenu.menu_item) = >- GMenu.menu ~packing:item#set_submenu () >-end >- >-(********************************************************************** >- HIGHER-LEVEL WIDGETS >-***********************************************************************) >- >-(*class stats width height = >- let pixmap = GDraw.pixmap ~width ~height () in >- let area = >- pixmap#set_foreground `WHITE; >- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height (); >- GMisc.pixmap pixmap ~width ~height ~xpad:4 ~ypad:8 () >- in >- object (self) >- inherit GObj.widget_full area#as_widget >- val mutable maxim = ref 0. >- val mutable scale = ref 1. >- val mutable min_scale = 1. >- val values = Array.make width 0. >- val mutable active = false >- >- method redraw () = >- scale := min_scale; >- while !maxim > !scale do >- scale := !scale *. 1.5 >- done; >- pixmap#set_foreground `WHITE; >- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height (); >- pixmap#set_foreground `BLACK; >- for i = 0 to width - 1 do >- self#rect i values.(max 0 (i - 1)) values.(i) >- done >- >- method activate a = active <- a; if a then self#redraw () >- >- method scale h = truncate ((float height) *. h /. !scale) >- >- method private rect i v' v = >- let h = self#scale v in >- let h' = self#scale v' in >- let h1 = min h' h in >- let h2 = max h' h in >- pixmap#set_foreground `BLACK; >- pixmap#rectangle >- ~filled:true ~x:i ~y:(height - h1) ~width:1 ~height:h1 (); >- for h = h1 + 1 to h2 do >- let v = truncate (65535. *. (float (h - h1) /. float (h2 - h1))) in >- let v = (v / 4096) * 4096 in (* Only use 16 gray levels *) >- pixmap#set_foreground (`RGB (v, v, v)); >- pixmap#rectangle >- ~filled:true ~x:i ~y:(height - h) ~width:1 ~height:1 (); >- done >- >- method push v = >- let need_max = values.(0) = !maxim in >- for i = 0 to width - 2 do >- values.(i) <- values.(i + 1) >- done; >- values.(width - 1) <- v; >- if need_max then begin >- maxim := 0.; >- for i = 0 to width - 1 do maxim := max !maxim values.(i) done >- end else >- maxim := max !maxim v; >- if active then begin >- let need_resize = >- !maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in >- if need_resize then >- self#redraw () >- else begin >- pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap); >- pixmap#set_foreground `WHITE; >- pixmap#rectangle >- ~filled:true ~x:(width - 1) ~y:0 ~width:1 ~height (); >- self#rect (width - 1) values.(width - 2) values.(width - 1) >- end; >- area#misc#draw None >- end >- end >-*) >-let clientWritten = ref 0. >-let serverWritten = ref 0. >-let emitRate2 = ref 0. >-let receiveRate2 = ref 0. >- >-let rate2str v = >- if v > 9.9e3 then begin >- if v > 9.9e6 then >- Format.sprintf "%1.0f MiB/s" (v /. 1e6) >- else if v > 999e3 then >- Format.sprintf "%1.1f MiB/s" (v /. 1e6) >- else >- Format.sprintf "%1.0f KiB/s" (v /. 1e3) >- end else begin >- if v > 990. then >- Format.sprintf "%1.1f KiB/s" (v /. 1e3) >- else if v > 99. then >- Format.sprintf "%1.2f KiB/s" (v /. 1e3) >- else >- " " >- end >- >-let mib = 1024. *. 1024. >-let kib2str v = >- if v > 100_000_000. then >- Format.sprintf "%.0f MiB" (v /. mib) >- else if v > 1_000_000. then >- Format.sprintf "%.1f MiB" (v /. mib) >- else if v > 1024. then >- Format.sprintf "%.1f KiB" (v /. 1024.) >- else >- Format.sprintf "%.0f B" v >- >-let statistics () = >- let title = "Statistics" in >- let t = GWindow.dialog ~title () in >- let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in >- t_dismiss#grab_default (); >- let dismiss () = t#misc#hide () in >- ignore (t_dismiss#connect#clicked ~callback:dismiss); >- ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true)); >- >-(* let emission = new stats 320 50 in >- t#vbox#pack ~expand:false ~padding:4 (emission :> GObj.widget); >- let reception = new stats 320 50 in >- t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);*) >- >- let cols = new GTree.column_list in >- let c_1 = cols#add Gobject.Data.string in >- let c_client = cols#add Gobject.Data.string in >- let c_server = cols#add Gobject.Data.string in >- let c_total = cols#add Gobject.Data.string in >- let lst = GTree.list_store cols in >- let l = GTree.view ~model:lst ~enable_search:false ~packing:(t#vbox#add) () in >- l#selection#set_mode `NONE; >- ignore (l#append_column (GTree.view_column ~title:"" >- ~renderer:(GTree.cell_renderer_text [], ["text", c_1]) ())); >- ignore (l#append_column (GTree.view_column ~title:"Client" >- ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_client]) ())); >- ignore (l#append_column (GTree.view_column ~title:"Server" >- ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_server]) ())); >- ignore (l#append_column (GTree.view_column ~title:"Total" >- ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_total]) ())); >- let rate_row = lst#append () in >- ignore (lst#set rate_row c_1 "Reception rate"); >- let receive_row = lst#append () in >- ignore (lst#set receive_row c_1 "Data received"); >- let data_row = lst#append () in >- ignore (lst#set data_row c_1 "File data written"); >-(* >- ignore (t#event#connect#map ~callback:(fun _ -> >- emission#activate true; >- reception#activate true; >- false)); >- ignore (t#event#connect#unmap ~callback:(fun _ -> >- emission#activate false; >- reception#activate false; >- false));*) >- >- let delay = 0.5 in >- let a = 0.5 in >- let b = 0.8 in >- >- let emittedBytes = ref 0. in >- let emitRate = ref 0. in >- let receivedBytes = ref 0. in >- let receiveRate = ref 0. in >- >- let stopCounter = ref 0 in >- >- let updateTable () = >- let row = rate_row in >- lst#set ~row ~column:c_client (rate2str !receiveRate2); >- lst#set ~row ~column:c_server (rate2str !emitRate2); >- lst#set ~row ~column:c_total (rate2str (!receiveRate2 +. !emitRate2)); >- let row = receive_row in >- lst#set ~row ~column:c_client (kib2str !receivedBytes); >- lst#set ~row ~column:c_server (kib2str !emittedBytes); >- lst#set ~row ~column:c_total (kib2str (!receivedBytes +. !emittedBytes)); >- let row = data_row in >- lst#set ~row ~column:c_client (kib2str !clientWritten); >- lst#set ~row ~column:c_server (kib2str !serverWritten); >- lst#set ~row ~column:c_total (kib2str (!clientWritten +. !serverWritten)) >- in >- let timeout _ = >- emitRate := >- a *. !emitRate +. >- (1. -. a) *. (!Remote.emittedBytes -. !emittedBytes) /. delay; >- emitRate2 := >- b *. !emitRate2 +. >- (1. -. b) *. (!Remote.emittedBytes -. !emittedBytes) /. delay; >-(* emission#push !emitRate;*) >- receiveRate := >- a *. !receiveRate +. >- (1. -. a) *. (!Remote.receivedBytes -. !receivedBytes) /. delay; >- receiveRate2 := >- b *. !receiveRate2 +. >- (1. -. b) *. (!Remote.receivedBytes -. !receivedBytes) /. delay; >-(* reception#push !receiveRate;*) >- emittedBytes := !Remote.emittedBytes; >- receivedBytes := !Remote.receivedBytes; >- if !stopCounter > 0 then decr stopCounter; >- if !stopCounter = 0 then begin >- emitRate2 := 0.; receiveRate2 := 0.; >- end; >- updateTable (); >- !stopCounter <> 0 >- in >- let startStats () = >- if !stopCounter = 0 then begin >- emittedBytes := !Remote.emittedBytes; >- receivedBytes := !Remote.receivedBytes; >- stopCounter := -1; >- ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.)) >- ~callback:timeout) >- end else >- stopCounter := -1 >- in >- let stopStats () = stopCounter := 10 in >- (t, startStats, stopStats) >- >-(* ------ *) >- >-let fatalError message = >- let () = >- try Trace.log (message ^ "\n") >- with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *) >- let title = "Fatal error" in >- let t = >- GWindow.dialog ~parent:(toplevelWindow ()) >- ~border_width:6 ~modal:true ~resizable:false () in >- t#vbox#set_spacing 12; >- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >- ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG >- ~yalign:0. ~packing:h1#pack ()); >- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >- ignore (GMisc.label >- ~markup:(primaryText title ^ "\n\n" ^ >- escapeMarkup (transcode message)) >- ~line_wrap:true ~selectable:true ~yalign:0. ~packing:v1#add ()); >- t#add_button_stock `QUIT `QUIT; >- t#set_default_response `QUIT; >- t#show(); ignore (t#run ()); t#destroy (); >- exit 1 >- >-(* ------ *) >- >-let tryAgainOrQuit = fatalError >- >-(* ------ *) >- >-let getFirstRoot () = >- let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection" >- ~modal:true ~resizable:true () in >- t#misc#grab_focus (); >- >- let hb = GPack.hbox >- ~packing:(t#vbox#pack ~expand:false ~padding:15) () in >- ignore(GMisc.label ~text:tryAgainMessage >- ~justify:`LEFT >- ~packing:(hb#pack ~expand:false ~padding:15) ()); >- >- let f1 = GPack.hbox ~spacing:4 >- ~packing:(t#vbox#pack ~expand:true ~padding:4) () in >- ignore (GMisc.label ~text:"Dir:" ~packing:(f1#pack ~expand:false) ()); >- let fileE = GEdit.entry ~packing:f1#add () in >- fileE#misc#grab_focus (); >- let b = GFile.chooser_button ~action:`SELECT_FOLDER >- ~title:"Select a local directory" >- ~packing:(f1#pack ~expand:false) () in >- ignore (b#connect#selection_changed ~callback:(fun () -> >- if not fileE#is_focus then >- fileE#set_text (match b#filename with None -> "" | Some s -> s))); >- ignore (fileE#connect#changed ~callback:(fun () -> >- if fileE#is_focus then ignore (b#set_filename fileE#text))); >- >- let f3 = t#action_area in >- let result = ref None in >- let contCommand() = >- result := Some(fileE#text); >- t#destroy () in >- let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in >- ignore (quitButton#connect#clicked >- ~callback:(fun () -> result := None; t#destroy())); >- let contButton = GButton.button ~stock:`OK ~packing:f3#add () in >- ignore (contButton#connect#clicked ~callback:contCommand); >- ignore (fileE#connect#activate ~callback:contCommand); >- contButton#grab_default (); >- t#show (); >- ignore (t#connect#destroy ~callback:GMain.Main.quit); >- GMain.Main.main (); >- match !result with None -> None >- | Some file -> >- Some(Clroot.clroot2string(Clroot.ConnectLocal(Some file))) >- >-(* ------ *) >- >-let getSecondRoot () = >- let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection" >- ~modal:true ~resizable:true () in >- t#misc#grab_focus (); >- >- let message = "Please enter the second directory you want to synchronize." in >- >- let vb = t#vbox in >- let hb = GPack.hbox ~packing:(vb#pack ~expand:false ~padding:15) () in >- ignore(GMisc.label ~text:message >- ~justify:`LEFT >- ~packing:(hb#pack ~expand:false ~padding:15) ()); >- let helpB = GButton.button ~stock:`HELP ~packing:hb#add () in >- ignore (helpB#connect#clicked >- ~callback:(fun () -> okBox ~parent:t ~title:"Picking roots" ~typ:`INFO >- ~message:helpmessage)); >- >- let result = ref None in >- >- let f = GPack.vbox ~packing:(vb#pack ~expand:false) () in >- >- let f1 = GPack.hbox ~spacing:4 ~packing:f#add () in >- ignore (GMisc.label ~text:"Directory:" ~packing:(f1#pack ~expand:false) ()); >- let fileE = GEdit.entry ~packing:f1#add () in >- fileE#misc#grab_focus (); >- let b = GFile.chooser_button ~action:`SELECT_FOLDER >- ~title:"Select a local directory" >- ~packing:(f1#pack ~expand:false) () in >- ignore (b#connect#selection_changed ~callback:(fun () -> >- if not fileE#is_focus then >- fileE#set_text (match b#filename with None -> "" | Some s -> s))); >- ignore (fileE#connect#changed ~callback:(fun () -> >- if fileE#is_focus then ignore (b#set_filename fileE#text))); >- >- let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in >- let localB = GButton.radio_button ~packing:(f0#pack ~expand:false) >- ~label:"Local" () in >- let sshB = GButton.radio_button ~group:localB#group >- ~packing:(f0#pack ~expand:false) >- ~label:"SSH" () in >- let rshB = GButton.radio_button ~group:localB#group >- ~packing:(f0#pack ~expand:false) ~label:"RSH" () in >- let socketB = GButton.radio_button ~group:sshB#group >- ~packing:(f0#pack ~expand:false) ~label:"Socket" () in >- >- let f2 = GPack.hbox ~spacing:4 ~packing:f#add () in >- ignore (GMisc.label ~text:"Host:" ~packing:(f2#pack ~expand:false) ()); >- let hostE = GEdit.entry ~packing:f2#add () in >- >- ignore (GMisc.label ~text:"(Optional) User:" >- ~packing:(f2#pack ~expand:false) ()); >- let userE = GEdit.entry ~packing:f2#add () in >- >- ignore (GMisc.label ~text:"Port:" >- ~packing:(f2#pack ~expand:false) ()); >- let portE = GEdit.entry ~packing:f2#add () in >- >- let varLocalRemote = ref (`Local : [`Local|`SSH|`RSH|`SOCKET]) in >- let localState() = >- varLocalRemote := `Local; >- hostE#misc#set_sensitive false; >- userE#misc#set_sensitive false; >- portE#misc#set_sensitive false; >- b#misc#set_sensitive true in >- let remoteState() = >- hostE#misc#set_sensitive true; >- b#misc#set_sensitive false; >- match !varLocalRemote with >- `SOCKET -> >- (portE#misc#set_sensitive true; userE#misc#set_sensitive false) >- | _ -> >- (portE#misc#set_sensitive false; userE#misc#set_sensitive true) in >- let protoState x = >- varLocalRemote := x; >- remoteState() in >- ignore (localB#connect#clicked ~callback:localState); >- ignore (sshB#connect#clicked ~callback:(fun () -> protoState(`SSH))); >- ignore (rshB#connect#clicked ~callback:(fun () -> protoState(`RSH))); >- ignore (socketB#connect#clicked ~callback:(fun () -> protoState(`SOCKET))); >- localState(); >- let getRoot() = >- let file = fileE#text in >- let user = userE#text in >- let host = hostE#text in >- let port = portE#text in >- match !varLocalRemote with >- `Local -> >- Clroot.clroot2string(Clroot.ConnectLocal(Some file)) >- | `SSH | `RSH -> >- Clroot.clroot2string( >- Clroot.ConnectByShell((if !varLocalRemote=`SSH then "ssh" else "rsh"), >- host, >- (if user="" then None else Some user), >- (if port="" then None else Some port), >- Some file)) >- | `SOCKET -> >- Clroot.clroot2string( >- (* FIX: report an error if the port entry is not well formed *) >- Clroot.ConnectBySocket(host, >- portE#text, >- Some file)) in >- let contCommand() = >- try >- let root = getRoot() in >- result := Some root; >- t#destroy () >- with Failure _ -> >- if portE#text="" then >- okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Please enter a port" >- else okBox ~parent:t ~title:"Error" ~typ:`ERROR >- ~message:"The port you specify must be an integer" >- | _ -> >- okBox ~parent:t ~title:"Error" ~typ:`ERROR >- ~message:"Something's wrong with the values you entered, try again" in >- let f3 = t#action_area in >- let quitButton = >- GButton.button ~stock:`QUIT ~packing:f3#add () in >- ignore (quitButton#connect#clicked ~callback:safeExit); >- let contButton = >- GButton.button ~stock:`OK ~packing:f3#add () in >- ignore (contButton#connect#clicked ~callback:contCommand); >- contButton#grab_default (); >- ignore (fileE#connect#activate ~callback:contCommand); >- >- t#show (); >- ignore (t#connect#destroy ~callback:GMain.Main.quit); >- GMain.Main.main (); >- !result >- >-(* ------ *) >- >-let getPassword rootName msg = >- let t = >- GWindow.dialog ~parent:(toplevelWindow ()) >- ~title:"Unison: SSH connection" ~position:`CENTER >- ~modal:true ~resizable:false ~border_width:6 () in >- t#misc#grab_focus (); >- >- t#vbox#set_spacing 12; >- >- let header = >- primaryText >- (Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in >- >- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >- ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG >- ~yalign:0. ~packing:h1#pack ()); >- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >- ignore(GMisc.label ~markup:(header ^ "\n\n" ^ >- escapeMarkup (Unicode.protect msg)) >- ~selectable:true ~yalign:0. ~packing:v1#pack ()); >- >- let passwordE = GEdit.entry ~packing:v1#pack ~visibility:false () in >- passwordE#misc#grab_focus (); >- >- t#add_button_stock `QUIT `QUIT; >- t#add_button_stock `OK `OK; >- t#set_default_response `OK; >- ignore (passwordE#connect#activate ~callback:(fun _ -> t#response `OK)); >- >- t#show(); >- let res = t#run () in >- let pwd = passwordE#text in >- t#destroy (); >- gtk_sync true; >- begin match res with >- `DELETE_EVENT | `QUIT -> safeExit (); "" >- | `OK -> pwd >- end >- >-let termInteract = Some getPassword >- >-(* ------ *) >- >-module React = struct >- type 'a t = { mutable state : 'a; mutable observers : ('a -> unit) list } >- >- let make v = >- let res = { state = v; observers = [] } in >- let update v = >- if res.state <> v then begin >- res.state <- v; List.iter (fun f -> f v) res.observers >- end >- in >- (res, update) >- >- let const v = fst (make v) >- >- let add_observer x f = x.observers <- f :: x.observers >- >- let state x = x.state >- >- let lift f x = >- let (res, update) = make (f (state x)) in >- add_observer x (fun v -> update (f v)); >- res >- >- let lift2 f x y = >- let (res, update) = make (f (state x) (state y)) in >- add_observer x (fun v -> update (f v (state y))); >- add_observer y (fun v -> update (f (state x) v)); >- res >- >- let lift3 f x y z = >- let (res, update) = make (f (state x) (state y) (state z)) in >- add_observer x (fun v -> update (f v (state y) (state z))); >- add_observer y (fun v -> update (f (state x) v (state z))); >- add_observer z (fun v -> update (f (state x) (state y) v)); >- res >- >- let iter f x = f (state x); add_observer x f >- >- type 'a event = { mutable ev_observers : ('a -> unit) list } >- >- let make_event () = >- let res = { ev_observers = [] } in >- let trigger v = List.iter (fun f -> f v) res.ev_observers in >- (res, trigger) >- >- let add_ev_observer x f = x.ev_observers <- f :: x.ev_observers >- >- let hold v e = >- let (res, update) = make v in >- add_ev_observer e update; >- res >- >- let iter_ev f e = add_ev_observer e f >- >- let lift_ev f e = >- let (res, trigger) = make_event () in >- add_ev_observer e (fun x -> trigger (f x)); >- res >- >- module Ops = struct >- let (>>) x f = lift f x >- let (>|) x f = iter f x >- >- let (>>>) x f = lift_ev f x >- let (>>|) x f = iter_ev f x >- end >-end >- >-module GtkReact = struct >- let entry (e : #GEdit.entry) = >- let (res, update) = React.make e#text in >- ignore (e#connect#changed ~callback:(fun () -> update (e#text))); >- res >- >- let text_combo ((c, _) : _ GEdit.text_combo) = >- let (res, update) = React.make c#active in >- ignore (c#connect#changed ~callback:(fun () -> update (c#active))); >- res >- >- let toggle_button (b : #GButton.toggle_button) = >- let (res, update) = React.make b#active in >- ignore (b#connect#toggled ~callback:(fun () -> update (b#active))); >- res >- >- let file_chooser (c : #GFile.chooser) = >- let (res, update) = React.make c#filename in >- ignore (c#connect#selection_changed >- ~callback:(fun () -> update (c#filename))); >- res >- >- let current_tree_view_selection (t : #GTree.view) = >- let m =t#model in >- Safelist.map (fun p -> m#get_row_reference p) t#selection#get_selected_rows >- >- let tree_view_selection_changed t = >- let (res, trigger) = React.make_event () in >- ignore (t#selection#connect#changed >- ~callback:(fun () -> trigger (current_tree_view_selection t))); >- res >- >- let tree_view_selection t = >- React.hold (current_tree_view_selection t) (tree_view_selection_changed t) >- >- let label (l : #GMisc.label) x = React.iter (fun v -> l#set_text v) x >- >- let label_underlined (l : #GMisc.label) x = >- React.iter (fun v -> l#set_text v; l#set_use_underline true) x >- >- let label_markup (l : #GMisc.label) x = >- React.iter (fun v -> l#set_text v; l#set_use_markup true) x >- >- let show w x = >- React.iter (fun b -> if b then w#misc#show () else w#misc#hide ()) x >- let set_sensitive w x = React.iter (fun b -> w#misc#set_sensitive b) x >-end >- >-open React.Ops >- >-(* ------ *) >- >-(* Resize an object (typically, a label with line wrapping) so that it >- use all its available space *) >-let adjustSize (w : #GObj.widget) = >- let notYet = ref true in >- ignore >- (w#misc#connect#size_allocate ~callback:(fun r -> >- if !notYet then begin >- notYet := false; >- (* JV: I have no idea where the 12 comes from. Without it, >- a window resize may happen. *) >- w#misc#set_size_request ~width:(max 10 (r.Gtk.width - 12)) () >- end)) >- >-let createProfile parent = >- let assistant = GAssistant.assistant ~modal:true () in >- assistant#set_transient_for parent#as_window; >- assistant#set_modal true; >- assistant#set_title "Profile Creation"; >- >- let nonEmpty s = s <> "" in >-(* >- let integerRe = >- Str.regexp "\\([+-]?[0-9]+\\|0o[0-7]+\\|0x[0-9a-zA-Z]+\\)" in >-*) >- let integerRe = Str.regexp "[0-9]+" in >- let isInteger s = >- Str.string_match integerRe s 0 && Str.matched_string s = s in >- >- (* Introduction *) >- let intro = >- GMisc.label >- ~xpad:12 ~ypad:12 >- ~text:"Welcome to the Unison Profile Creation Assistant.\n\n\ >- Click \"Next\" to begin." >- () in >- ignore >- (assistant#append_page >- ~title:"Profile Creation" >- ~page_type:`INTRO >- ~complete:true >- intro#as_widget); >- >- (* Profile name and description *) >- let description = GPack.vbox ~border_width:12 ~spacing:6 () in >- adjustSize >- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >- ~text:"Please enter the name of the profile and \ >- possibly a short description." >- ~packing:(description#pack ~expand:false) ()); >- let tbl = >- let al = GBin.alignment ~packing:(description#pack ~expand:false) () in >- al#set_left_padding 12; >- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 >- ~packing:(al#add) () in >- let nameEntry = >- GEdit.entry ~activates_default:true >- ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in >- let name = GtkReact.entry nameEntry in >- ignore (GMisc.label ~text:"Profile _name:" ~xalign:0. >- ~use_underline:true ~mnemonic_widget:nameEntry >- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >- let labelEntry = >- GEdit.entry ~activates_default:true >- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in >- let label = GtkReact.entry labelEntry in >- ignore (GMisc.label ~text:"_Description:" ~xalign:0. >- ~use_underline:true ~mnemonic_widget:labelEntry >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); >- let existingProfileLabel = >- GMisc.label ~xalign:1. ~packing:(description#pack ~expand:false) () >- in >- adjustSize existingProfileLabel; >- GtkReact.label_markup existingProfileLabel >- (name >> fun s -> Format.sprintf " <i>Profile %s already exists.</i>" >- (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:"<b>Configuration</b>" ~xalign:0. >- ~packing:(vb#pack ~expand:false) ()); >- let al = GBin.alignment ~packing:(vb#add) () in >- al#set_left_padding 12; >- let vb = GPack.vbox ~spacing:6 ~packing:(al#add) () in >- let requirementLabel = >- GMisc.label ~xalign:0. ~line_wrap:true >- ~packing:(vb#pack ~expand:false) () >- in >- adjustSize requirementLabel; >- GtkReact.label requirementLabel >- (kind >> fun k -> >- match k with >- `Local -> >- "" >- | `SSH -> >- "There must be an SSH client installed on this machine, \ >- and Unison and an SSH server installed on the remote machine." >- | `RSH -> >- "There must be an RSH client installed on this machine, \ >- and Unison and an RSH server installed on the remote machine." >- | `SOCKET -> >- "There must be a Unison server running on the remote machine, \ >- listening on the port that you specify here. \ >- (Use \"Unison -socket xxx\" on the remote machine to start \ >- the Unison server.)"); >- let connDescLabel = >- GMisc.label ~xalign:0. ~line_wrap:true >- ~packing:(vb#pack ~expand:false) () >- in >- adjustSize connDescLabel; >- GtkReact.label connDescLabel >- (kind >> fun k -> >- match k with >- `Local -> "" >- | `SSH -> "Please enter the host to connect to and a user name, \ >- if different from your user name on this machine." >- | `RSH -> "Please enter the host to connect to and a user name, \ >- if different from your user name on this machine." >- | `SOCKET -> "Please enter the host and port to connect to."); >- let tbl = >- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >- al#set_left_padding 12; >- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 >- ~packing:(al#add) () in >- let hostEntry = >- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in >- let host = GtkReact.entry hostEntry in >- ignore (GMisc.label ~text:"_Host:" ~xalign:0. >- ~use_underline:true ~mnemonic_widget:hostEntry >- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >- let userEntry = >- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () >- in >- GtkReact.show userEntry (isSocket >> not); >- let user = GtkReact.entry userEntry in >- GtkReact.show >- (GMisc.label ~text:"_User:" ~xalign:0. ~yalign:0. >- ~use_underline:true ~mnemonic_widget:userEntry >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()) >- (isSocket >> not); >- let portEntry = >- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () >- in >- GtkReact.show portEntry isSocket; >- let port = GtkReact.entry portEntry in >- GtkReact.show >- (GMisc.label ~text:"_Port:" ~xalign:0. ~yalign:0. >- ~use_underline:true ~mnemonic_widget:portEntry >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()) >- isSocket; >- let compressLabel = >- GMisc.label ~xalign:0. ~line_wrap:true >- ~text:"Data compression can greatly improve performance \ >- on slow connections. However, it may slow down \ >- things on (fast) local networks." >- ~packing:(vb#pack ~expand:false) () >- in >- adjustSize compressLabel; >- GtkReact.show compressLabel isSSH; >- let compressButton = >- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >- al#set_left_padding 12; >- (GButton.check_button ~label:"Enable _compression" ~use_mnemonic:true >- ~active:true ~packing:(al#add) ()) >- in >- GtkReact.show compressButton isSSH; >- let compress = GtkReact.toggle_button compressButton in >-(*XXX Disabled for now... *) >-(* >- adjustSize >- (GMisc.label ~xalign:0. ~line_wrap:true >- ~text:"If this is possible, it is recommended that Unison \ >- attempts to connect immediately to the remote machine, \ >- so that it can perform some auto-detections." >- ~packing:(vb#pack ~expand:false) ()); >- let connectImmediately = >- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >- al#set_left_padding 12; >- GtkReact.toggle_button >- (GButton.check_button ~label:"Connect _immediately" ~use_mnemonic:true >- ~active:true ~packing:(al#add) ()) >- in >- let connectImmediately = >- React.lift2 (&&) connectImmediately (isLocal >> not) in >-*) >- let pageComplete = >- React.lift2 (||) isLocal >- (React.lift2 (&&) (host >> nonEmpty) >- (React.lift2 (||) (isSocket >> not) (port >> isInteger))) >- in >- ignore >- (assistant#append_page >- ~title:"Connection Setup" >- ~page_type:`CONTENT >- connection#as_widget); >- pageComplete >| setPageComplete connection; >- >- (* Connection to server *) >-(*XXX Disabled for now... Fill in this page >- let connectionInProgress = GMisc.label ~text:"..." () in >- let p = >- assistant#append_page >- ~title:"Connecting to Server..." >- ~page_type:`PROGRESS >- connectionInProgress#as_widget >- in >- ignore >- (assistant#connect#prepare (fun () -> >- if assistant#current_page = p then begin >- if React.state connectImmediately then begin >- (* XXXX start connection... *) >- assistant#set_page_complete connectionInProgress#as_widget true >- end else >- assistant#set_current_page (p + 1) >- end)); >-*) >- >- (* Directory selection *) >- let directorySelection = GPack.vbox ~border_width:12 ~spacing:6 () in >- adjustSize >- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >- ~text:"Please select the two directories that you want to synchronize." >- ~packing:(directorySelection#pack ~expand:false) ()); >- let secondDirLabel1 = >- GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >- ~text:"The second directory is relative to your home \ >- directory on the remote machine." >- ~packing:(directorySelection#pack ~expand:false) () >- in >- adjustSize secondDirLabel1; >- GtkReact.show secondDirLabel1 ((React.lift2 (||) isLocal isSocket) >> not); >- let secondDirLabel2 = >- GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >- ~text:"The second directory is relative to \ >- the working directory of the Unison server \ >- running on the remote machine." >- ~packing:(directorySelection#pack ~expand:false) () >- in >- adjustSize secondDirLabel2; >- GtkReact.show secondDirLabel2 isSocket; >- let tbl = >- let al = >- GBin.alignment ~packing:(directorySelection#pack ~expand:false) () in >- al#set_left_padding 12; >- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 >- ~packing:(al#add) () in >-(*XXX Should focus on this button when becomes visible... *) >- let firstDirButton = >- GFile.chooser_button ~action:`SELECT_FOLDER ~title:"First Directory" >- ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () >- in >- isLocal >| (fun b -> firstDirButton#set_title >- (if b then "First Directory" else "Local Directory")); >- GtkReact.label_underlined >- (GMisc.label ~xalign:0. >- ~mnemonic_widget:firstDirButton >- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()) >- (isLocal >> fun b -> >- if b then "_First directory:" else "_Local directory:"); >- let noneToEmpty o = match o with None -> "" | Some s -> s in >- let firstDir = GtkReact.file_chooser firstDirButton >> noneToEmpty in >- let secondDirButton = >- GFile.chooser_button ~action:`SELECT_FOLDER ~title:"Second Directory" >- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in >- let secondDirLabel = >- GMisc.label ~xalign:0. >- ~text:"Se_cond directory:" >- ~use_underline:true ~mnemonic_widget:secondDirButton >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () in >- GtkReact.show secondDirButton isLocal; >- GtkReact.show secondDirLabel isLocal; >- let remoteDirEdit = >- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () >- in >- let remoteDirLabel = >- GMisc.label ~xalign:0. >- ~text:"_Remote directory:" >- ~use_underline:true ~mnemonic_widget:remoteDirEdit >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () >- in >- GtkReact.show remoteDirEdit (isLocal >> not); >- GtkReact.show remoteDirLabel (isLocal >> not); >- let secondDir = >- React.lift3 (fun b l r -> if b then l else r) isLocal >- (GtkReact.file_chooser secondDirButton >> noneToEmpty) >- (GtkReact.entry remoteDirEdit) >- in >- ignore >- (assistant#append_page >- ~title:"Directory Selection" >- ~page_type:`CONTENT >- directorySelection#as_widget); >- React.lift2 (||) (isLocal >> not) (React.lift2 (<>) firstDir secondDir) >- >| setPageComplete directorySelection; >- >- (* Specific options *) >- let options = GPack.vbox ~border_width:18 ~spacing:12 () in >- (* Do we need to set specific options for FAT partitions? >- If under Windows, then all the options are set properly, except for >- ignoreinodenumbers in case one replica is on a FAT partition on a >- remote non-Windows machine. As this is unlikely, we do not >- handle this case. *) >- let fat = >- if Util.osType = `Win32 then >- React.const false >- else begin >- let vb = >- GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in >- let fatLabel = >- GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >- ~text:"Select the following option if one of your \ >- directory is on a FAT partition. This is typically \ >- the case for a USB stick." >- ~packing:(vb#pack ~expand:false) () >- in >- adjustSize fatLabel; >- let fatButton = >- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >- al#set_left_padding 12; >- (GButton.check_button >- ~label:"Synchronization involving a _FAT partition" >- ~use_mnemonic:true ~active:false ~packing:(al#add) ()) >- in >- GtkReact.toggle_button fatButton >- end >- in >- (* Fastcheck is safe except on FAT partitions and on Windows when >- not in Unicode mode where there is a very slight chance of >- missing an update when a file is moved onto another with the same >- modification time. Nowadays, FAT is rarely used on working >- partitions. In most cases, we should be in Unicode mode. >- Thus, it seems sensible to always enable fastcheck. *) >-(* >- let fastcheck = isLocal >> not >> (fun b -> b || Util.osType = `Win32) in >-*) >- (* Unicode mode can be problematic when the source machine is under >- Windows and the remote machine is not, as Unison may have already >- been used using the legacy Latin 1 encoding. Cygwin also did not >- handle Unicode before version 1.7. *) >- let vb = GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in >- let askUnicode = React.const false in >-(* isLocal >> not >> fun b -> (b || Util.isCygwin) && Util.osType = `Win32 in*) >- GtkReact.show vb askUnicode; >- adjustSize >- (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >- ~text:"When synchronizing in case insensitive mode, \ >- Unison has to make some assumptions regarding \ >- filename encoding. If ensure, use Unicode." >- ~packing:(vb#pack ~expand:false) ()); >- let vb = >- let al = GBin.alignment >- ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in >- al#set_left_padding 12; >- GPack.vbox ~spacing:0 ~packing:(al#add) () >- in >- ignore >- (GMisc.label ~xalign:0. ~text:"Filename encoding:" >- ~packing:(vb#pack ~expand:false) ()); >- let hb = >- let al = GBin.alignment >- ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in >- al#set_left_padding 12; >- GPack.button_box `VERTICAL ~layout:`START >- ~spacing:0 ~packing:(al#add) () >- in >- let unicodeButton = >- GButton.radio_button ~label:"_Unicode" ~use_mnemonic:true ~active:true >- ~packing:(hb#add) () >- in >- ignore >- (GButton.radio_button ~label:"_Latin 1" ~use_mnemonic:true >- ~group:unicodeButton#group ~packing:(hb#add) ()); >-(* >- let unicode = >- React.lift2 (||) (askUnicode >> not) (GtkReact.toggle_button unicodeButton) >- in >-*) >- let p = >- assistant#append_page >- ~title:"Specific Options" ~complete:true >- ~page_type:`CONTENT >- options#as_widget >- in >- ignore >- (assistant#connect#prepare ~callback:(fun () -> >- if assistant#current_page = p && >- not (Util.osType <> `Win32 || React.state askUnicode) >- then >- assistant#set_current_page (p + 1))); >- >- let conclusion = >- GMisc.label >- ~xpad:12 ~ypad:12 >- ~text:"You have now finished filling in the profile.\n\n\ >- Click \"Apply\" to create it." >- () in >- ignore >- (assistant#append_page >- ~title:"Done" ~complete:true >- ~page_type:`CONFIRM >- conclusion#as_widget); >- >- let profileName = ref None in >- let saveProfile () = >- let filename = Prefs.profilePathname (React.state name) in >- begin try >- let ch = >- System.open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename >- in >- Printf.fprintf ch "# Unison preferences\n"; >- let label = React.state label in >- if label <> "" then Printf.fprintf ch "label = %s\n" label; >- Printf.fprintf ch "root = %s\n" (React.state firstDir); >- let secondDir = React.state secondDir in >- let host = React.state host in >- let user = match React.state user with "" -> None | u -> Some u in >- let secondRoot = >- match React.state kind with >- `Local -> Clroot.ConnectLocal (Some secondDir) >- | `SSH -> Clroot.ConnectByShell >- ("ssh", host, user, None, Some secondDir) >- | `RSH -> Clroot.ConnectByShell >- ("rsh", host, user, None, Some secondDir) >- | `SOCKET -> Clroot.ConnectBySocket >- (host, React.state port, Some secondDir) >- in >- Printf.fprintf ch "root = %s\n" (Clroot.clroot2string secondRoot); >- if React.state compress && React.state kind = `SSH then >- Printf.fprintf ch "sshargs = -C\n"; >-(* >- if React.state fastcheck then >- Printf.fprintf ch "fastcheck = true\n"; >- if React.state unicode then >- Printf.fprintf ch "unicode = true\n"; >-*) >- if React.state fat then Printf.fprintf ch "fat = true\n"; >- close_out ch; >- profileName := Some (React.state name) >- with Sys_error _ as e -> >- okBox ~parent:assistant ~typ:`ERROR ~title:"Could not save profile" >- ~message:(Uicommon.exn2string e) >- end; >- assistant#destroy (); >- in >- ignore (assistant#connect#close ~callback:saveProfile); >- ignore (assistant#connect#destroy ~callback:GMain.Main.quit); >- ignore (assistant#connect#cancel ~callback:assistant#destroy); >- assistant#show (); >- GMain.Main.main (); >- !profileName >- >-(* ------ *) >- >-let nameOfType t = >- match t with >- `BOOL -> "boolean" >- | `BOOLDEF -> "boolean" >- | `INT -> "integer" >- | `STRING -> "text" >- | `STRING_LIST -> "text list" >- | `CUSTOM -> "custom" >- | `UNKNOWN -> "unknown" >- >-let defaultValue t = >- match t with >- `BOOL -> ["true"] >- | `BOOLDEF -> ["true"] >- | `INT -> ["0"] >- | `STRING -> [""] >- | `STRING_LIST -> [] >- | `CUSTOM -> [] >- | `UNKNOWN -> [] >- >-let editPreference parent nm ty vl = >- let t = >- GWindow.dialog ~parent ~border_width:12 >- ~title:"Edit the Preference" >- ~modal:true () in >- let vb = t#vbox in >- vb#set_spacing 6; >- >- let isList = >- match ty with >- `STRING_LIST | `CUSTOM | `UNKNOWN -> true >- | _ -> false >- in >- let columns = if isList then 5 else 4 in >- let rows = if isList then 3 else 2 in >- let tbl = >- GPack.table ~rows ~columns ~col_spacings:12 ~row_spacings:6 >- ~packing:(vb#pack ~expand:false) () in >- ignore (GMisc.label ~text:"Preference:" ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >- ignore (GMisc.label ~text:"Description:" ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); >- ignore (GMisc.label ~text:"Type:" ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:2 ~expand:`NONE) ()); >- ignore (GMisc.label ~text:(Unicode.protect nm) ~xalign:0. ~selectable:true () >- ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)); >- let (doc, _, _) = Prefs.documentation nm in >- ignore (GMisc.label ~text:doc ~xalign:0. ~selectable:true () >- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X)); >- ignore (GMisc.label ~text:(nameOfType ty) ~xalign:0. ~selectable:true () >- ~packing:(tbl#attach ~left:1 ~top:2 ~expand:`X)); >- let newValue = >- if isList then begin >- let valueLabel = >- GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. ~yalign:0. >- ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) () >- in >- let cols = new GTree.column_list in >- let c_value = cols#add Gobject.Data.string in >- let c_ml = cols#add Gobject.Data.caml in >- let lst_store = GTree.list_store cols in >- let lst = >- let sw = >- GBin.scrolled_window ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) >- ~shadow_type:`IN ~height:200 ~width:400 >- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in >- GTree.view ~model:lst_store ~headers_visible:false >- ~reorderable:true ~packing:sw#add () in >- valueLabel#set_mnemonic_widget (Some (lst :> GObj.widget)); >- let column = >- GTree.view_column >- ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) () >- in >- ignore (lst#append_column column); >- let vb = >- GPack.button_box >- `VERTICAL ~layout:`START ~spacing:6 >- ~packing:(tbl#attach ~left:2 ~top:3 ~expand:`NONE) () >- in >- let selection = GtkReact.tree_view_selection lst in >- let hasSel = selection >> fun l -> l <> [] in >- let addB = >- GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in >- let removeB = >- GButton.button ~stock:`REMOVE ~packing:(vb#pack ~expand:false) () in >- let editB = >- GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in >- let upB = >- GButton.button ~stock:`GO_UP ~packing:(vb#pack ~expand:false) () in >- let downB = >- GButton.button ~stock:`GO_DOWN ~packing:(vb#pack ~expand:false) () in >- List.iter (fun b -> b#set_xalign 0.) [addB; removeB; editB; upB; downB]; >- GtkReact.set_sensitive removeB hasSel; >- let editLabel = >- GMisc.label ~text:"Edited _item:" >- ~use_underline:true ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:4 ~expand:`NONE) () >- in >- let editEntry = >- GEdit.entry ~packing:(tbl#attach ~left:1 ~top:4 ~expand:`X) () in >- editLabel#set_mnemonic_widget (Some (editEntry :> GObj.widget)); >- let edit = GtkReact.entry editEntry in >- let edited = >- React.lift2 >- (fun l txt -> >- match l with >- [rf] -> lst_store#get ~row:rf#iter ~column:c_ml <> txt >- | _ -> false) >- selection edit >- in >- GtkReact.set_sensitive editB edited; >- let selectionChange = GtkReact.tree_view_selection_changed lst in >- selectionChange >>| (fun s -> >- match s with >- [rf] -> editEntry#set_text >- (lst_store#get ~row:rf#iter ~column:c_value) >- | _ -> ()); >- let add () = >- let txt = editEntry#text in >- let row = lst_store#append () in >- lst_store#set ~row ~column:c_value txt; >- lst_store#set ~row ~column:c_ml txt; >- lst#selection#select_iter row; >- lst#scroll_to_cell (lst_store#get_path row) column >- in >- ignore (addB#connect#clicked ~callback:add); >- ignore (editEntry#connect#activate ~callback:add); >- let remove () = >- match React.state selection with >- [rf] -> let i = rf#iter in >- if lst_store#iter_next i then >- lst#selection#select_iter i >- else begin >- let p = rf#path in >- if GTree.Path.prev p then >- lst#selection#select_path p >- end; >- ignore (lst_store#remove rf#iter) >- | _ -> () >- in >- ignore (removeB#connect#clicked ~callback:remove); >- let edit () = >- match React.state selection with >- [rf] -> let row = rf#iter in >- let txt = editEntry#text in >- lst_store#set ~row ~column:c_value txt; >- lst_store#set ~row ~column:c_ml txt >- | _ -> () >- in >- ignore (editB#connect#clicked ~callback:edit); >- let updateUpDown l = >- let (upS, downS) = >- match l with >- [rf] -> (GTree.Path.prev rf#path, lst_store#iter_next rf#iter) >- | _ -> (false, false) >- in >- upB#misc#set_sensitive upS; >- downB#misc#set_sensitive downS >- in >- selectionChange >>| updateUpDown; >- ignore (lst_store#connect#after#row_deleted >- ~callback:(fun _ -> updateUpDown (React.state selection))); >- let go_up () = >- match React.state selection with >- [rf] -> let p = rf#path in >- if GTree.Path.prev p then begin >- let i = rf#iter in >- let i' = lst_store#get_iter p in >- ignore (lst_store#swap i i'); >- lst#scroll_to_cell (lst_store#get_path i) column >- end; >- updateUpDown (React.state selection) >- | _ -> () >- in >- ignore (upB#connect#clicked ~callback:go_up); >- let go_down () = >- match React.state selection with >- [rf] -> let i = rf#iter in >- if lst_store#iter_next i then begin >- let i' = rf#iter in >- ignore (lst_store#swap i i'); >- lst#scroll_to_cell (lst_store#get_path i') column >- end; >- updateUpDown (React.state selection) >- | _ -> () >- in >- ignore (downB#connect#clicked ~callback:go_down); >- List.iter >- (fun v -> >- let row = lst_store#append () in >- lst_store#set ~row ~column:c_value (Unicode.protect v); >- lst_store#set ~row ~column:c_ml v) >- vl; >- (fun () -> >- let l = ref [] in >- lst_store#foreach >- (fun _ row -> l := lst_store#get ~row ~column:c_ml :: !l; false); >- List.rev !l) >- end else begin >- let v = List.hd vl in >- begin match ty with >- `BOOL | `BOOLDEF -> >- let hb = >- GPack.button_box `HORIZONTAL ~layout:`START >- ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) () >- in >- let isTrue = v = "true" || v = "yes" in >- let trueB = >- GButton.radio_button ~label:"_True" ~use_mnemonic:true >- ~active:isTrue ~packing:(hb#add) () >- in >- ignore >- (GButton.radio_button ~label:"_False" ~use_mnemonic:true >- ~group:trueB#group ~active:(not isTrue) ~packing:(hb#add) ()); >- ignore >- (GMisc.label ~text:"Value:" ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()); >- (fun () -> [if trueB#active then "true" else "false"]) >- | `INT | `STRING -> >- let valueEntry = >- GEdit.entry ~text:v ~width_chars: 40 >- ~activates_default:true >- ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) () >- in >- ignore >- (GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. >- ~mnemonic_widget:valueEntry >- ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()); >- (fun () -> [valueEntry#text]) >- | `STRING_LIST | `CUSTOM | `UNKNOWN -> >- assert false >- end >- end >- in >- >- let res = ref None in >- let cancelCommand () = t#destroy () in >- let cancelButton = >- GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in >- ignore (cancelButton#connect#clicked ~callback:cancelCommand); >- let okCommand _ = res := Some (newValue ()); t#destroy () in >- let okButton = >- GButton.button ~stock:`OK ~packing:t#action_area#add () in >- ignore (okButton#connect#clicked ~callback:okCommand); >- okButton#grab_default (); >- ignore (t#connect#destroy ~callback:GMain.Main.quit); >- t#show (); >- GMain.Main.main (); >- !res >- >- >-let markupRe = Str.regexp "<\\([a-z]+\\)>\\|</\\([a-z]+\\)>\\|&\\([a-z]+\\);" >-let entities = >- [("amp", "&"); ("lt", "<"); ("gt", ">"); ("quot", "\""); ("apos", "'")] >- >-let rec insertMarkupRec tags (t : #GText.view) s i tl = >- try >- let j = Str.search_forward markupRe s i in >- if j > i then >- t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i)); >- let tag = try Some (Str.matched_group 1 s) with Not_found -> None in >- match tag with >- Some tag -> >- insertMarkupRec tags t s (Str.group_end 0) >- ((try [List.assoc tag tags] with Not_found -> []) :: tl) >- | None -> >- let entity = try Some (Str.matched_group 3 s) with Not_found -> None in >- match entity with >- None -> >- insertMarkupRec tags t s (Str.group_end 0) (List.tl tl) >- | Some ent -> >- begin try >- t#buffer#insert ~tags:(List.flatten tl) (List.assoc ent entities) >- with Not_found -> () end; >- insertMarkupRec tags t s (Str.group_end 0) tl >- with Not_found -> >- let j = String.length s in >- if j > i then >- t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i)) >- >-let insertMarkup tags t s = >- t#buffer#set_text ""; insertMarkupRec tags t s 0 [] >- >-let documentPreference ~compact ~packing = >- let vb = GPack.vbox ~spacing:6 ~packing () in >- ignore (GMisc.label ~markup:"<b>Documentation</b>" ~xalign:0. >- ~packing:(vb#pack ~expand:false) ()); >- let al = GBin.alignment ~packing:(vb#pack ~expand:true ~fill:true) () in >- al#set_left_padding 12; >- let columns = if compact then 3 else 2 in >- let tbl = >- GPack.table ~rows:2 ~columns ~col_spacings:12 ~row_spacings:6 >- ~packing:(al#add) () in >- tbl#misc#set_sensitive false; >- ignore (GMisc.label ~text:"Short description:" ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >- ignore (GMisc.label ~text:"Long description:" ~xalign:0. ~yalign:0. >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); >- let shortDescr = >- GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) >- ~xalign:0. ~selectable:true () in >- let longDescr = >- let sw = >- if compact then >- GBin.scrolled_window ~height:128 ~width:640 >- ~packing:(tbl#attach ~left:0 ~top:2 ~right:2 ~expand:`BOTH) >- ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () >- else >- GBin.scrolled_window ~height:128 ~width:640 >- ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`BOTH) >- ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () >- in >- GText.view ~editable:false ~packing:sw#add ~wrap_mode:`WORD () >- in >- let (>>>) x f = f x in >- let newlineRe = Str.regexp "\n *" in >- let styleRe = Str.regexp "{\\\\\\([a-z]+\\) \\([^{}]*\\)}" in >- let verbRe = Str.regexp "\\\\verb|\\([^|]*\\)|" in >- let argRe = Str.regexp "\\\\ARG{\\([^{}]*\\)}" in >- let textttRe = Str.regexp "\\\\texttt{\\([^{}]*\\)}" in >- let emphRe = Str.regexp "\\\\emph{\\([^{}]*\\)}" in >- let sectionRe = Str.regexp "\\\\sectionref{\\([^{}]*\\)}{\\([^{}]*\\)}" in >- let emdash = Str.regexp_string "---" in >- let parRe = Str.regexp "\\\\par *" in >- let underRe = Str.regexp "\\\\_ *" in >- let dollarRe = Str.regexp "\\\\\\$ *" in >- let formatDoc doc = >- doc >>> >- Str.global_replace newlineRe " " >>> >- escapeMarkup >>> >- Str.global_substitute styleRe >- (fun s -> >- try >- let tag = >- match Str.matched_group 1 s with >- "em" -> "i" >- | "tt" -> "tt" >- | _ -> raise Exit >- in >- Format.sprintf "<%s>%s</%s>" tag (Str.matched_group 2 s) tag >- with Exit -> >- Str.matched_group 0 s) >>> >- Str.global_replace verbRe "<tt>\\1</tt>" >>> >- Str.global_replace argRe "<tt>\\1</tt>" >>> >- Str.global_replace textttRe "<tt>\\1</tt>" >>> >- Str.global_replace emphRe "<i>\\1</i>" >>> >- 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:"<b>Summary</b>" ~xalign:0. >- ~packing:(vb#pack ~expand:false) ()); >- let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >- al#set_left_padding 12; >- let tbl = >- GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 >- ~packing:(al#add) () in >- tbl#misc#set_sensitive false; >- ignore (GMisc.label ~text:"First root:" ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >- ignore (GMisc.label ~text:"Second root:" ~xalign:0. >- ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); >- let root1 = >- GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) >- ~xalign:0. ~selectable:true () in >- let root2 = >- GMisc.label ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) >- ~xalign:0. ~selectable:true () in >- >- let fillLst default = >- Uicommon.scanProfiles(); >- lst_store#clear (); >- Safelist.iter >- (fun (profile, info) -> >- let labeltext = >- match info.Uicommon.label with None -> "" | Some l -> l in >- let row = lst_store#append () in >- lst_store#set ~row ~column:c_name (Unicode.protect profile); >- lst_store#set ~row ~column:c_label (Unicode.protect labeltext); >- lst_store#set ~row ~column:c_ml (profile, info); >- if Some profile = default then begin >- lst#selection#select_iter row; >- lst#scroll_to_cell (lst_store#get_path row) vc_name >- end) >- (Safelist.sort (fun (p, _) (p', _) -> compare p p') !Uicommon.profilesAndRoots) >- in >- let selection = GtkReact.tree_view_selection lst in >- let hasSel = selection >> fun l -> l <> [] in >- let selInfo = >- selection >> fun l -> >- match l with >- [rf] -> Some (lst_store#get ~row:rf#iter ~column:c_ml, rf) >- | _ -> None >- in >- selInfo >| >- (fun info -> >- match info with >- Some ((profile, info), _) -> >- begin match info.Uicommon.roots with >- [r1; r2] -> root1#set_text (Unicode.protect r1); >- root2#set_text (Unicode.protect r2); >- tbl#misc#set_sensitive true >- | _ -> root1#set_text ""; root2#set_text ""; >- tbl#misc#set_sensitive false >- end >- | None -> >- root1#set_text ""; root2#set_text ""; >- tbl#misc#set_sensitive false); >- GtkReact.set_sensitive okButton hasSel; >- >- let vb = >- GPack.button_box >- `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) () >- in >- let addButton = >- GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in >- ignore (addButton#connect#clicked >- ~callback:(fun () -> >- match createProfile t with >- Some p -> fillLst (Some p) | None -> ())); >- let editButton = >- GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in >- ignore (editButton#connect#clicked >- ~callback:(fun () -> match React.state selInfo with >- None -> >- () >- | Some ((p, _), _) -> >- editProfile t p; fillLst (Some p))); >- GtkReact.set_sensitive editButton hasSel; >- let deleteProfile () = >- match React.state selInfo with >- Some ((profile, _), rf) -> >- if >- twoBox ~kind:`DIALOG_QUESTION ~parent:t ~title:"Profile Deletion" >- ~bstock:`CANCEL ~astock:`DELETE >- (Format.sprintf "Do you really want to delete profile %s?" >- (transcode profile)) >- then begin >- try >- System.unlink (Prefs.profilePathname profile); >- ignore (lst_store#remove rf#iter) >- with Unix.Unix_error _ -> () >- end >- | None -> >- () >- in >- let deleteButton = >- GButton.button ~stock:`DELETE ~packing:(vb#pack ~expand:false) () in >- ignore (deleteButton#connect#clicked ~callback:deleteProfile); >- GtkReact.set_sensitive deleteButton hasSel; >- List.iter (fun b -> b#set_xalign 0.) [addButton; editButton; deleteButton]; >- >- ignore (lst#connect#row_activated ~callback:(fun _ _ -> okCommand ())); >- fillLst None; >- lst#misc#grab_focus (); >- ignore (t#connect#destroy ~callback:GMain.Main.quit); >- t#show (); >- GMain.Main.main (); >- match React.state selInfo with >- Some ((p, _), _) when !ok -> Some p >- | _ -> None >- >-(* ------ *) >- >-let documentation sect = >- let title = "Documentation" in >- let t = GWindow.dialog ~title () in >- let t_dismiss = >- GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in >- t_dismiss#grab_default (); >- let dismiss () = t#destroy () in >- ignore (t_dismiss#connect#clicked ~callback:dismiss); >- ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true)); >- >- let (name, docstr) = Safelist.assoc sect Strings.docs in >- let hb = GPack.hbox ~packing:(t#vbox#pack ~expand:false ~padding:2) () in >- >- let t_text = >- new scrolled_text ~editable:false >- ~width:80 ~height:20 ~packing:(t#vbox#pack ~expand:true) () >- in >- t_text#insert docstr; >- >- let menuBar = >- GMenu.menu_bar ~border_width:0 >- ~packing:(hb#pack ~expand:true ~fill:false) () in >- let mi = GMenu.menu_item ~label:"Topics" () in >- menuBar#insert mi 0; >- >- let sect_idx = ref 0 in >- let idx = ref 0 in >- let menu = GMenu.menu ~packing:(mi#set_submenu) () in >- let addDocSection (shortname, (name, docstr)) = >- if shortname <> "" && name <> "" then begin >- if shortname = sect then sect_idx := !idx; >- incr idx; >- let item = GMenu.menu_item ~label:name ~packing:menu#append () in >- ignore >- (item#connect#activate ~callback:(fun () -> t_text#insert docstr)) >- end >- in >- Safelist.iter addDocSection Strings.docs; >- >- t#show () >- >-(* ------ *) >- >-let messageBox ~title ?(action = fun t -> t#destroy) message = >- let utitle = transcode title in >- let t = GWindow.dialog ~title:utitle ~position:`CENTER () in >- let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in >- t_dismiss#grab_default (); >- ignore (t_dismiss#connect#clicked ~callback:(action t)); >- let t_text = >- new scrolled_text ~editable:false >- ~width:80 ~height:20 ~packing:t#vbox#add () >- in >- t_text#insert message; >- ignore (t#event#connect#delete ~callback:(fun _ -> action t (); true)); >- t#show () >- >-(* twoBoxAdvanced: Display a message in a window and wait for the user >- to hit one of two buttons. Return true if the first button is >- chosen, false if the second button is chosen. Also has a button for >- showing more details to the user in a messageBox dialog *) >-let twoBoxAdvanced >- ~parent ~title ~message ~longtext ~advLabel ~astock ~bstock = >- let t = >- GWindow.dialog ~parent ~border_width:6 ~modal:true >- ~resizable:false () in >- t#vbox#set_spacing 12; >- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >- ignore (GMisc.image ~stock:`DIALOG_QUESTION ~icon_size:`DIALOG >- ~yalign:0. ~packing:h1#pack ()); >- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >- ignore (GMisc.label >- ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message) >- ~selectable:true ~yalign:0. ~packing:v1#add ()); >- t#add_button_stock `CANCEL `NO; >- let cmd () = >- messageBox ~title:"Details" longtext >- in >- t#add_button advLabel `HELP; >- t#add_button_stock `APPLY `YES; >- t#set_default_response `NO; >- let res = ref false in >- let setRes signal = >- match signal with >- `YES -> res := true; t#destroy () >- | `NO -> res := false; t#destroy () >- | `HELP -> cmd () >- | _ -> () >- in >- ignore (t#connect#response ~callback:setRes); >- ignore (t#connect#destroy ~callback:GMain.Main.quit); >- t#show(); >- GMain.Main.main(); >- !res >- >-let summaryBox ~parent ~title ~message ~f = >- let t = >- GWindow.dialog ~parent ~border_width:6 ~modal:true >- ~resizable:false ~focus_on_map:false () in >- t#vbox#set_spacing 12; >- let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >- ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG >- ~yalign:0. ~packing:h1#pack ()); >- let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >- ignore (GMisc.label >- ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message) >- ~selectable:true ~xalign:0. ~yalign:0. ~packing:v1#add ()); >- let exp = GBin.expander ~spacing:12 ~label:"Show details" ~packing:v1#add () in >- let t_text = >- new scrolled_text ~editable:false ~shadow_type:`IN >- ~width:60 ~height:10 ~packing:exp#add () >- in >- f (t_text#text); >- t#add_button_stock `OK `OK; >- t#set_default_response `OK; >- let setRes signal = t#destroy () in >- ignore (t#connect#response ~callback:setRes); >- ignore (t#connect#destroy ~callback:GMain.Main.quit); >- t#show(); >- GMain.Main.main() >- >-(********************************************************************** >- TOP-LEVEL WINDOW >- **********************************************************************) >- >-let displayWaitMessage () = >- make_busy (toplevelWindow ()); >- Trace.status (Uicommon.contactingServerMsg ()) >- >-(* ------ *) >- >-type status = NoStatus | Done | Failed >- >-let createToplevelWindow () = >- let toplevelWindow = >- GWindow.window ~kind:`TOPLEVEL ~position:`CENTER >- ~title:myNameCapitalized () >- in >- setToplevelWindow toplevelWindow; >- (* There is already a default icon under Windows, and transparent >- icons are not supported by all version of Windows *) >- if Util.osType <> `Win32 then toplevelWindow#set_icon (Some icon); >- let toplevelVBox = GPack.vbox ~packing:toplevelWindow#add () in >- >- (******************************************************************* >- Statistic window >- *******************************************************************) >- >- let (statWin, startStats, stopStats) = statistics () in >- >- (******************************************************************* >- Groups of things that are sensitive to interaction at the same time >- *******************************************************************) >- let grAction = ref [] in >- let grDiff = ref [] in >- let grGo = ref [] in >- let grRescan = ref [] in >- let grDetail = ref [] in >- let grAdd gr w = gr := w#misc::!gr in >- let grSet gr st = Safelist.iter (fun x -> x#set_sensitive st) !gr in >- let grDisactivateAll () = >- grSet grAction false; >- grSet grDiff false; >- grSet grGo false; >- grSet grRescan false; >- grSet grDetail false >- in >- >- (********************************************************************* >- Create the menu bar >- *********************************************************************) >- let topHBox = GPack.hbox ~packing:(toplevelVBox#pack ~expand:false) () in >- >- let menuBar = >- GMenu.menu_bar ~border_width:0 >- ~packing:(topHBox#pack ~expand:true) () in >- let menus = new gMenuFactory ~accel_modi:[] menuBar in >- let accel_group = menus#accel_group in >- toplevelWindow#add_accel_group accel_group; >- let add_submenu ?(modi=[]) label = >- let (menu, item) = menus#add_submenu label in >- (new gMenuFactory ~accel_group:(menus#accel_group) >- ~accel_path:(menus#accel_path ^ label ^ "/") >- ~accel_modi:modi menu, >- item) >- in >- let replace_submenu ?(modi=[]) label item = >- let menu = menus#replace_submenu item in >- new gMenuFactory ~accel_group:(menus#accel_group) >- ~accel_path:(menus#accel_path ^ label ^ "/") >- ~accel_modi:modi menu >- in >- >- let profileLabel = >- GMisc.label ~text:"" ~packing:(topHBox#pack ~expand:false ~padding:2) () in >- >- let displayNewProfileLabel () = >- let p = match !Prefs.profileName with None -> "" | Some p -> p in >- let label = Prefs.read Uicommon.profileLabel in >- let s = >- match p, label with >- "", _ -> "" >- | _, "" -> p >- | "default", _ -> label >- | _ -> Format.sprintf "%s (%s)" p label >- in >- toplevelWindow#set_title >- (if s = "" then myNameCapitalized else >- Format.sprintf "%s [%s]" myNameCapitalized s); >- let s = if s="" then "No profile" else "Profile: " ^ s in >- profileLabel#set_text (transcode s) >- in >- displayNewProfileLabel (); >- >- (********************************************************************* >- Create the menus >- *********************************************************************) >- let (fileMenu, _) = add_submenu "_Synchronization" in >- let (actionMenu, actionItem) = add_submenu "_Actions" in >- let (ignoreMenu, _) = add_submenu ~modi:[`SHIFT] "_Ignore" in >- let (sortMenu, _) = add_submenu "S_ort" in >- let (helpMenu, _) = add_submenu "_Help" in >- >- (********************************************************************* >- Action bar >- *********************************************************************) >- let actionBar = >- GButton.toolbar ~style:`BOTH >- (* 2003-0519 (stse): how to set space size in gtk 2.0? *) >- (* Answer from Jacques Garrigue: this can only be done in >- the user's.gtkrc, not programmatically *) >- ~orientation:`HORIZONTAL (* ~space_size:10 *) >- ~packing:(toplevelVBox#pack ~expand:false) () in >- >- (********************************************************************* >- Create the main window >- *********************************************************************) >- let mainWindowSW = >- GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:true) >- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () >- in >- let sizeMainWindow () = >- let ctx = mainWindowSW#misc#pango_context in >- let metrics = ctx#get_metrics () in >- let h = GPango.to_pixels (metrics#ascent+metrics#descent) in >- toplevelWindow#set_default_height >- ((h + 3) * (Prefs.read Uicommon.mainWindowHeight + 1) + 200) >- in >- let cols = new GTree.column_list in >- let c_replica1 = cols#add Gobject.Data.string in >- let c_action = cols#add Gobject.Data.gobject in >- let c_replica2 = cols#add Gobject.Data.string in >- let c_status = cols#add Gobject.Data.gobject_option in >- let c_statust = cols#add Gobject.Data.string in >- let c_path = cols#add Gobject.Data.string in >- (*let c_rowid = cols#add Gobject.Data.uint in*) >- (* With current implementation the [list_store] view model and [theState] >- array have one-to-one correspondence, so that list_store's tree path index >- is the same as theState array index. >- This changes when, for example, [tree_store] would be used instead of >- list_store, or a separate view-only sorting is implemented without sorting >- the backing theState array. In that case, the column [c_rowid] must be >- used to store the index of [theState] array in the view model. Tree path >- index must not be used directly as [theState] array index and vice versa. *) >- let mainWindowModel = GTree.list_store cols in >- let mainWindow = >- GTree.view ~model:mainWindowModel ~packing:(mainWindowSW#add) >- ~headers_clickable:false ~enable_search:false () in >- mainWindow#selection#set_mode `MULTIPLE; >- ignore (mainWindow#append_column >- (GTree.view_column >- ~title:(" ") >- ~renderer:(GTree.cell_renderer_text [], ["text", c_replica1]) ())); >- ignore (mainWindow#append_column >- (GTree.view_column ~title:" Action " >- ~renderer:(GTree.cell_renderer_pixbuf [], ["pixbuf", c_action]) ())); >- ignore (mainWindow#append_column >- (GTree.view_column >- ~title:(" ") >- ~renderer:(GTree.cell_renderer_text [], ["text", c_replica2]) ())); >- let status_view_col = GTree.view_column ~title:" Status " >- ~renderer:(GTree.cell_renderer_pixbuf [], ["pixbuf", c_status]) () in >- let status_t_rend = GTree.cell_renderer_text [] in >- status_view_col#pack ~expand:false ~from:`END status_t_rend; >- status_view_col#add_attribute status_t_rend "text" c_statust; >- ignore (mainWindow#append_column status_view_col); >- ignore (mainWindow#append_column >- (GTree.view_column ~title:" Path " >- ~renderer:(GTree.cell_renderer_text [], ["text", c_path]) ())); >- >- let setMainWindowColumnHeaders s = >- Array.iteri >- (fun i data -> >- (mainWindow#get_column i)#set_title data) >- [| " " ^ Unicode.protect (String.sub s 0 12) ^ " "; " Action "; >- " " ^ Unicode.protect (String.sub s 15 12) ^ " "; " Status "; >- " Path" |]; >- in >- sizeMainWindow (); >- >- (* See above for comment about tree path index and [theState] array index >- equivalence. *) >- let siOfRow f path = >- let row = mainWindowModel#get_iter path in >- let i = (GTree.Path.get_indices path).(0) in >- (*let i = mainWindowModel#get ~row ~column:c_rowid in*) >- f i !theState.(i) row >- in >- let rowOfSi i = GTree.Path.create [i] in >- let currentNumberRows () = mainWindow#selection#count_selected_rows in >- let currentRow () = >- match currentNumberRows () with >- | 1 -> siOfRow (fun i si row -> Some (i, !theState.(i), row)) >- (List.hd mainWindow#selection#get_selected_rows) >- | _ -> None >- in >- let currentSelectedIter f = >- Safelist.iter (fun r -> siOfRow f r) >- mainWindow#selection#get_selected_rows >- in >- let currentSelectedFold f a = >- Safelist.fold_left (fun a r -> siOfRow (fun _ si _ -> f a si) r) >- a mainWindow#selection#get_selected_rows >- in >- let currentSelectedExists pred = >- Safelist.exists (fun r -> siOfRow (fun _ si _ -> pred si) r) >- mainWindow#selection#get_selected_rows >- in >- >- (********************************************************************* >- Create the details window >- *********************************************************************) >- >- let showDetCommand () = >- let details = >- match currentRow () with >- None -> >- None >- | Some (_, si, _) -> >- let path = Path.toString si.ri.path1 in >- match si.whatHappened with >- Some (Util.Failed _, Some det) -> >- Some ("Merge execution details for file" ^ >- transcodeFilename path, >- det) >- | _ -> >- match si.ri.replicas with >- Problem err -> >- Some ("Errors for file " ^ transcodeFilename path, err) >- | Different diff -> >- let prefix s l = >- Safelist.map (fun err -> Format.sprintf "%s%s\n" s err) l >- in >- let errors = >- Safelist.append >- (prefix "[root 1]: " diff.errors1) >- (prefix "[root 2]: " diff.errors2) >- in >- let errors = >- match si.whatHappened with >- Some (Util.Failed err, _) -> err :: errors >- | _ -> errors >- in >- Some ("Errors for file " ^ transcodeFilename path, >- String.concat "\n" errors) >- in >- match details with >- None -> ((* Should not happen *)) >- | Some (title, details) -> messageBox ~title (transcode details) >- in >- >- let detailsWindowSW = >- GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false) >- ~shadow_type:`IN ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () >- in >- let detailsWindow = >- GText.view ~editable:false ~packing:detailsWindowSW#add () >- in >- let detailsWindowPath = detailsWindow#buffer#create_tag [] in >- let detailsWindowInfo = >- detailsWindow#buffer#create_tag [`FONT_DESC (Lazy.force fontMonospace)] in >- let detailsWindowError = >- detailsWindow#buffer#create_tag [`WRAP_MODE `WORD] in >- detailsWindow#misc#set_size_chars ~height:3 ~width:112 (); >- detailsWindow#misc#set_can_focus false; >- >- let updateButtons () = >- if not !busy then >- let actionPossible si = >- match si.whatHappened, si.ri.replicas with >- None, Different _ -> true >- | _ -> false >- in >- match currentRow () with >- None -> >- grSet grAction (currentSelectedExists actionPossible); >- grSet grDiff false; >- grSet grDetail false >- | Some (_, si, _) -> >- let details = >- begin match si.ri.replicas with >- Different diff -> diff.errors1 <> [] || diff.errors2 <> [] >- | Problem _ -> true >- end >- || >- begin match si.whatHappened with >- Some (Util.Failed _, _) -> true >- | _ -> false >- end >- in >- grSet grDetail details; >- let activateAction = actionPossible si in >- let activateDiff = >- activateAction && >- match si.ri.replicas with >- Different {rc1 = {typ = `FILE}; rc2 = {typ = `FILE}} -> >- true >- | _ -> >- false >- in >- grSet grAction activateAction; >- grSet grDiff activateDiff >- in >- >- let makeRowVisible row = >- mainWindow#scroll_to_cell row status_view_col (* just a dummy column *) >- in >- >-(* >- let makeFirstUnfinishedVisible pRiInFocus = >- let im = Array.length !theState in >- let rec find i = >- if i >= im then makeRowVisible im else >- match pRiInFocus (!theState.(i).ri), !theState.(i).whatHappened with >- true, None -> makeRowVisible i >- | _ -> find (i+1) in >- find 0 >- in >-*) >- >- let updateDetails () = >- begin match currentRow () with >- None -> >- detailsWindow#buffer#set_text "" >- | Some (_, si, _) -> >- let (formated, details) = >- match si.whatHappened with >- | Some(Util.Failed(s), _) -> >- (false, s) >- | None | Some(Util.Succeeded, _) -> >- match si.ri.replicas with >- Problem _ -> >- (false, Uicommon.details2string si.ri " ") >- | Different _ -> >- (true, Uicommon.details2string si.ri " ") >- in >- let path = Path.toString si.ri.path1 in >- detailsWindow#buffer#set_text ""; >- detailsWindow#buffer#insert ~tags:[detailsWindowPath] >- (transcodeFilename path); >- let len = String.length details in >- let details = >- if details.[len - 1] = '\n' then String.sub details 0 (len - 1) >- else details >- in >- if details <> "" then >- detailsWindow#buffer#insert >- ~tags:[if formated then detailsWindowInfo else detailsWindowError] >- ("\n" ^ transcode details) >- end; >- (* Display text *) >- updateButtons () in >- >- (********************************************************************* >- Status window >- *********************************************************************) >- >- let statusHBox = GPack.hbox ~packing:(toplevelVBox#pack ~expand:false) () in >- >- let progressBar = >- GRange.progress_bar ~packing:(statusHBox#pack ~expand:false) () in >- >- progressBar#misc#set_size_chars ~height:1 ~width:28 (); >- progressBar#set_show_text true; >- progressBar#set_pulse_step 0.02; >- let progressBarPulse = ref false in >- >- let statusWindow = >- GMisc.statusbar ~packing:(statusHBox#pack ~expand:true) () in >- let statusContext = statusWindow#new_context ~name:"status" in >- ignore (statusContext#push ""); >- >- let displayStatus m = >- statusContext#pop (); >- if !progressBarPulse then progressBar#pulse (); >- ignore (statusContext#push (transcode m)); >- (* Force message to be displayed immediately *) >- gtk_sync false >- in >- >- let formatStatus major minor = (Util.padto 30 (major ^ " ")) ^ minor in >- >- (* Tell the Trace module about the status printer *) >- Trace.messageDisplayer := displayStatus; >- Trace.statusFormatter := formatStatus; >- Trace.sendLogMsgsToStderr := false; >- >- (********************************************************************* >- Functions used to print in the main window >- *********************************************************************) >- let delayUpdates = ref false in >- >- let select row scroll = >- delayUpdates := true; >- mainWindow#selection#unselect_all (); >- mainWindow#selection#select_path row; >- mainWindow#set_cursor row status_view_col (* just a dummy column *); >- delayUpdates := false; >- if scroll then makeRowVisible row; >- updateDetails () >- in >- let selectI i scroll = select (rowOfSi i) scroll in >- >- ignore (mainWindow#selection#connect#changed ~callback: >- (fun () -> if not !delayUpdates then updateDetails ())); >- >- let nextInteresting () = >- let l = Array.length !theState in >- let start = match currentRow () with Some (i, _, _) -> i + 1 | None -> 0 in >- let rec loop i = >- if i < l then >- match !theState.(i).ri.replicas with >- Different {direction = dir} >- when not (Prefs.read Uicommon.auto) || isConflict dir -> >- selectI i true >- | _ -> >- loop (i + 1) in >- loop start in >- let selectSomethingIfPossible () = >- if currentNumberRows () = 0 then nextInteresting () in >- >- let columnsOf si = >- let oldPath = Path.empty in >- let status = >- match si.ri.replicas with >- Different {direction = Conflict _} | Problem _ -> >- NoStatus >- | _ -> >- match si.whatHappened with >- None -> NoStatus >- | Some (Util.Succeeded, _) -> Done >- | Some (Util.Failed _, _) -> Failed >- in >- let (r1, action, r2, path) = >- Uicommon.reconItem2stringList oldPath si.ri in >- (r1, action, r2, status, path) >- in >- >- let greenPixel = "00dd00" in >- let redPixel = "ff2040" in >- let lightbluePixel = "8888FF" in >- let orangePixel = "ff9303" in >-(* >- let yellowPixel = "999900" in >- let blackPixel = "000000" in >-*) >- let buildPixmap p = >- GdkPixbuf.from_xpm_data p in >- let buildPixmaps f c1 = >- (buildPixmap (f c1), buildPixmap (f lightbluePixel)) in >- >- let doneIcon = buildPixmap Pixmaps.success in >- let failedIcon = buildPixmap Pixmaps.failure in >- let rightArrow = buildPixmaps Pixmaps.copyAB greenPixel in >- let leftArrow = buildPixmaps Pixmaps.copyBA greenPixel in >- let orangeRightArrow = buildPixmaps Pixmaps.copyAB orangePixel in >- let orangeLeftArrow = buildPixmaps Pixmaps.copyBA orangePixel in >- let ignoreAct = buildPixmaps Pixmaps.ignore redPixel in >- let failedIcons = (failedIcon, failedIcon) in >- let mergeLogo = buildPixmaps Pixmaps.mergeLogo greenPixel in >-(* >- let rightArrowBlack = buildPixmap (Pixmaps.copyAB blackPixel) in >- let leftArrowBlack = buildPixmap (Pixmaps.copyBA blackPixel) in >- let mergeLogoBlack = buildPixmap (Pixmaps.mergeLogo blackPixel) in >-*) >- >- let getArrow j action = >- let changedFromDefault = match !theState.(j).ri.replicas with >- Different diff -> diff.direction <> diff.default_direction >- | _ -> false in >- let sel pixmaps = >- if changedFromDefault then snd pixmaps else fst pixmaps in >- let pixmaps = >- match action with >- Uicommon.AError -> failedIcons >- | Uicommon.ASkip _ -> ignoreAct >- | Uicommon.ALtoR false -> rightArrow >- | Uicommon.ALtoR true -> orangeRightArrow >- | Uicommon.ARtoL false -> leftArrow >- | Uicommon.ARtoL true -> orangeLeftArrow >- | Uicommon.AMerge -> mergeLogo >- in >- sel pixmaps >- in >- >- >- let getStatusIcon = function >- | Failed -> Some failedIcon >- | Done -> Some doneIcon >- | NoStatus -> None in >- >- let displayRowAction row i action = >- mainWindowModel#set ~row ~column:c_action (getArrow i action) in >- let displayRowStatus row status = >- mainWindowModel#set ~row ~column:c_status (getStatusIcon status); >- if status <> NoStatus then >- mainWindowModel#set ~row ~column:c_statust "" in >- let displayRowPath row path = >- mainWindowModel#set ~row ~column:c_path (transcodeFilename path) in >- let displayRow row i r1 r2 action status path = >- mainWindowModel#set ~row ~column:c_replica1 r1; >- mainWindowModel#set ~row ~column:c_replica2 r2; >- displayRowAction row i action; >- displayRowStatus row status; >- displayRowPath row path; >- (*mainWindowModel#set ~row ~column:c_rowid i;*) >- in >- >- let displayMain() = >- (* The call to mainWindow#clear below side-effect current, >- so we save the current value before we clear out the main window and >- rebuild it. *) >- let savedCurrent = mainWindow#selection#get_selected_rows in >- mainWindow#set_model None; >- mainWindowModel#clear (); >- let tot = Array.length !theState - 1 in >- let totf = float_of_int (tot + 1) in >- progressBar#set_text (Printf.sprintf "Displaying %i items..." (tot + 1)); >- for i = 0 to tot do >- if i mod 1024 = 0 then begin >- progressBar#set_fraction (max 0. (min 1. ((float_of_int i) /. totf))); >- gtk_sync false >- end; >- >- let (r1, action, r2, status, path) = columnsOf !theState.(i) in >- >- let row = mainWindowModel#append () in >- displayRow row i r1 r2 action status path; >- done; >- mainWindow#set_model (Some mainWindowModel#coerce); >- match savedCurrent with >- | [] -> selectSomethingIfPossible () >- | [x] -> select x true >- | _ -> Safelist.iter (fun p -> mainWindow#selection#select_path p) savedCurrent; >- >- progressBar#set_text ""; progressBar#set_fraction 0.; >- updateDetails (); (* Do we need this line? *) >- in >- >- let redisplay i si iter = >- let (_, action, _, status, path) = columnsOf si in >- displayRowAction iter i action; >- displayRowStatus iter status; >- if status = Failed then displayRowPath iter (path ^ >- " [failed: click on this line for details]"); >- in >- >- let fastRedisplay i = >- let si = !theState.(i) in >- let iter = mainWindowModel#get_iter (rowOfSi i) in >- let (_, action, _, status, path) = columnsOf si in >- displayRowStatus iter status; >- if status = Failed then begin >- displayRowPath iter (path ^ >- " [failed: click on this line for details]"); >- match currentRow () with >- | Some (_, csi, _) when csi = si -> updateDetails () >- | Some _ | None -> () >- end >- in >- >- let updateRowStatus i newstatus = >- let row = mainWindowModel#get_iter (rowOfSi i) in >- let oldstatus = mainWindowModel#get ~row ~column:c_statust in >- if oldstatus <> newstatus then mainWindowModel#set ~row ~column:c_statust newstatus >- in >- >- let totalBytesToTransfer = ref Uutil.Filesize.zero in >- let totalBytesTransferred = ref Uutil.Filesize.zero in >- >- let t0 = ref 0. in >- let t1 = ref 0. in >- let lastFrac = ref 0. in >- let oldWritten = ref 0. in >- let writeRate = ref 0. in >- let displayGlobalProgress v = >- if v = 0. || abs_float (v -. !lastFrac) > 1. then begin >- lastFrac := v; >- progressBar#set_fraction (max 0. (min 1. (v /. 100.))) >- end; >- if v < 0.001 then >- progressBar#set_text " " >- else begin >- let t = Unix.gettimeofday () in >- let delta = t -. !t1 in >- if delta >= 0.5 then begin >- t1 := t; >- let remTime = >- if v >= 100. then "00:00 remaining" else >- let t = truncate ((!t1 -. !t0) *. (100. -. v) /. v +. 0.5) in >- Format.sprintf "%02d:%02d remaining" (t / 60) (t mod 60) >- in >- let written = !clientWritten +. !serverWritten in >- let b = 0.64 ** delta in >- writeRate := >- b *. !writeRate +. >- (1. -. b) *. (written -. !oldWritten) /. delta; >- oldWritten := written; >- let rate = !writeRate (*!emitRate2 +. !receiveRate2*) in >- let txt = >- if rate > 99. then >- Format.sprintf "%s (%s)" remTime (rate2str rate) >- else >- remTime >- in >- progressBar#set_text txt >- end >- end >- in >- >- let showGlobalProgress b = >- (* Concatenate the new message *) >- totalBytesTransferred := Uutil.Filesize.add !totalBytesTransferred b; >- let v = >- (Uutil.Filesize.percentageOfTotalSize >- !totalBytesTransferred !totalBytesToTransfer) >- in >- displayGlobalProgress v >- in >- >- let root1IsLocal = ref true in >- let root2IsLocal = ref true in >- >- let initGlobalProgress b = >- let (root1,root2) = Globals.roots () in >- root1IsLocal := fst root1 = Local; >- root2IsLocal := fst root2 = Local; >- totalBytesToTransfer := b; >- totalBytesTransferred := Uutil.Filesize.zero; >- t0 := Unix.gettimeofday (); t1 := !t0; >- writeRate := 0.; oldWritten := !clientWritten +. !serverWritten; >- displayGlobalProgress 0. >- in >- >- let showProgress i bytes dbg = >- let i = Uutil.File.toLine i in >- let item = !theState.(i) in >- item.bytesTransferred <- Uutil.Filesize.add item.bytesTransferred bytes; >- let b = item.bytesTransferred in >- let len = item.bytesToTransfer in >- let newstatus = >- if b = Uutil.Filesize.zero || len = Uutil.Filesize.zero then "start " >- else if len = Uutil.Filesize.zero then >- Printf.sprintf "%5s " (Uutil.Filesize.toString b) >- else Util.percent2string (Uutil.Filesize.percentageOfTotalSize b len) in >- let dbg = if Trace.enabled "progress" then dbg ^ "/" else "" in >- let newstatus = dbg ^ newstatus in >- updateRowStatus i newstatus; >- showGlobalProgress bytes; >- gtk_sync false; >- begin match item.ri.replicas with >- Different diff -> >- begin match diff.direction with >- Replica1ToReplica2 -> >- if !root2IsLocal then >- clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes >- else >- serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes >- | Replica2ToReplica1 -> >- if !root1IsLocal then >- clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes >- else >- serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes >- | Conflict _ | Merge -> >- (* Diff / merge *) >- clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes >- end >- | _ -> >- assert false >- end >- in >- >- (* Install showProgress so that we get called back by low-level >- file transfer stuff *) >- Uutil.setProgressPrinter showProgress; >- >- (* Apply new ignore patterns to the current state, expecting that the >- number of reconitems will grow smaller. Adjust the display, being >- careful to keep the cursor as near as possible to its position >- before the new ignore patterns take effect. *) >- let ignoreAndRedisplay () = >- let lst = Array.to_list !theState in >- (* FIX: we should actually test whether any prefix is now ignored *) >- let keep sI = not (Globals.shouldIgnore sI.ri.path1) in >- theState := Array.of_list (Safelist.filter keep lst); >- displayMain() in >- >- let sortAndRedisplay () = >- let compareRIs = Sortri.compareReconItems() in >- Array.stable_sort (fun si1 si2 -> compareRIs si1.ri si2.ri) !theState; >- displayMain() in >- >- (****************************************************************** >- Main detect-updates-and-reconcile logic >- ******************************************************************) >- >- let commitUpdates () = >- Trace.status "Updating synchronizer state"; >- let t = Trace.startTimer "Updating synchronizer state" in >- gtk_sync true; >- Update.commitUpdates(); >- Trace.showTimer t >- in >- >- let clearMainWindow () = >- grDisactivateAll (); >- make_busy toplevelWindow; >- mainWindowModel#clear (); >- detailsWindow#buffer#set_text "" >- in >- >- let detectUpdatesAndReconcile () = >- clearMainWindow (); >- startStats (); >- progressBarPulse := true; >- sync_action := Some (fun () -> progressBar#pulse ()); >- let findUpdates () = >- let t = Trace.startTimer "Checking for updates" in >- Trace.status "Looking for changes"; >- let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in >- Trace.showTimer t; >- updates in >- let reconcile updates = >- let t = Trace.startTimer "Reconciling" in >- let reconRes = Recon.reconcileAll ~allowPartial:true updates in >- Trace.showTimer t; >- reconRes in >- let (reconItemList, thereAreEqualUpdates, dangerousPaths) = >- reconcile (findUpdates ()) in >- if not !Update.foundArchives then commitUpdates (); >- if reconItemList = [] then begin >- if !Update.foundArchives then commitUpdates (); >- if thereAreEqualUpdates then >- Trace.status >- "Replicas have been changed only in identical ways since last sync" >- else >- Trace.status "Everything is up to date" >- end else >- Trace.status "Check and/or adjust selected actions; then press Go"; >- theState := >- Array.of_list >- (Safelist.map >- (fun ri -> { ri = ri; >- bytesTransferred = Uutil.Filesize.zero; >- bytesToTransfer = Uutil.Filesize.zero; >- whatHappened = None }) >- reconItemList); >- unsynchronizedPaths := >- Some (Safelist.map (fun ri -> ri.path1) reconItemList, []); >- progressBarPulse := false; sync_action := None; displayGlobalProgress 0.; >- displayMain(); >- progressBarPulse := false; sync_action := None; displayGlobalProgress 0.; >- stopStats (); >- grSet grGo (Array.length !theState > 0); >- grSet grRescan true; >- make_interactive toplevelWindow; >- if Prefs.read Globals.confirmBigDeletes then begin >- if dangerousPaths <> [] then begin >- Prefs.set Globals.batch false; >- Util.warn (Uicommon.dangerousPathMsg dangerousPaths) >- end; >- end; >- in >- >- (********************************************************************* >- Help menu >- *********************************************************************) >- let addDocSection (shortname, (name, docstr)) = >- if shortname = "about" then >- ignore (helpMenu#add_image_item >- ~stock:`ABOUT ~callback:(fun () -> documentation shortname) >- name) >- else if shortname <> "" && name <> "" then >- ignore (helpMenu#add_item >- ~callback:(fun () -> documentation shortname) >- name) in >- Safelist.iter addDocSection Strings.docs; >- >- (********************************************************************* >- Ignore menu >- *********************************************************************) >- let addRegExpByPath pathfunc = >- Util.StringSet.iter (fun pat -> Uicommon.addIgnorePattern pat) >- (currentSelectedFold >- (fun s si -> Util.StringSet.add (pathfunc si.ri.path1) s) >- Util.StringSet.empty); >- ignoreAndRedisplay () >- in >- grAdd grAction >- (ignoreMenu#add_item ~key:GdkKeysyms._i >- ~callback:(fun () -> getLock (fun () -> >- addRegExpByPath Uicommon.ignorePath)) >- "Permanently Ignore This _Path"); >- grAdd grAction >- (ignoreMenu#add_item ~key:GdkKeysyms._E >- ~callback:(fun () -> getLock (fun () -> >- addRegExpByPath Uicommon.ignoreExt)) >- "Permanently Ignore Files with this _Extension"); >- grAdd grAction >- (ignoreMenu#add_item ~key:GdkKeysyms._N >- ~callback:(fun () -> getLock (fun () -> >- addRegExpByPath Uicommon.ignoreName)) >- "Permanently Ignore Files with this _Name (in any Dir)"); >- >- (* >- grAdd grRescan >- (ignoreMenu#add_item ~callback: >- (fun () -> getLock ignoreDialog) "Edit ignore patterns"); >- *) >- >- (********************************************************************* >- Sort menu >- *********************************************************************) >- grAdd grRescan >- (sortMenu#add_item >- ~callback:(fun () -> getLock (fun () -> >- Sortri.sortByName(); >- sortAndRedisplay())) >- "Sort by _Name"); >- grAdd grRescan >- (sortMenu#add_item >- ~callback:(fun () -> getLock (fun () -> >- Sortri.sortBySize(); >- sortAndRedisplay())) >- "Sort by _Size"); >- grAdd grRescan >- (sortMenu#add_item >- ~callback:(fun () -> getLock (fun () -> >- Sortri.sortNewFirst(); >- sortAndRedisplay())) >- "Sort Ne_w Entries First (toggle)"); >- grAdd grRescan >- (sortMenu#add_item >- ~callback:(fun () -> getLock (fun () -> >- Sortri.restoreDefaultSettings(); >- sortAndRedisplay())) >- "_Default Ordering"); >- >- (********************************************************************* >- Main function : synchronize >- *********************************************************************) >- let synchronize () = >- if Array.length !theState = 0 then >- Trace.status "Nothing to synchronize" >- else begin >- grDisactivateAll (); >- make_busy toplevelWindow; >- >- Trace.status "Propagating changes"; >- Transport.logStart (); >- let totalLength = >- Array.fold_left >- (fun l si -> >- si.bytesTransferred <- Uutil.Filesize.zero; >- let len = >- if si.whatHappened = None then Common.riLength si.ri else >- Uutil.Filesize.zero >- in >- si.bytesToTransfer <- len; >- Uutil.Filesize.add l len) >- Uutil.Filesize.zero !theState in >- initGlobalProgress totalLength; >- let t = Trace.startTimer "Propagating changes" in >- let im = Array.length !theState in >- let rec loop i actions pRiThisRound = >- if i < im then begin >- let theSI = !theState.(i) in >- let textDetailed = ref None in >- let action = >- match theSI.whatHappened with >- None -> >- if not (pRiThisRound theSI.ri) then >- return () >- else >- catch (fun () -> >- Transport.transportItem >- theSI.ri (Uutil.File.ofLine i) >- (fun title text -> >- textDetailed := (Some text); >- if Prefs.read Uicommon.confirmmerge then >- twoBoxAdvanced >- ~parent:toplevelWindow >- ~title:title >- ~message:("Do you want to commit the changes to" >- ^ " the replicas ?") >- ~longtext:text >- ~advLabel:"View details..." >- ~astock:`YES >- ~bstock:`NO >- else >- true) >- >>= (fun () -> >- return Util.Succeeded)) >- (fun e -> >- match e with >- Util.Transient s -> >- return (Util.Failed s) >- | _ -> >- fail e) >- >>= (fun res -> >- let rem = >- Uutil.Filesize.sub >- theSI.bytesToTransfer theSI.bytesTransferred >- in >- if rem <> Uutil.Filesize.zero then >- showProgress (Uutil.File.ofLine i) rem "done"; >- theSI.whatHappened <- Some (res, !textDetailed); >- fastRedisplay i; >-(* JV (7/09): It does not seem that useful to me to scroll the display >- to make the first unfinished item visible. The scrolling is way >- too fast, and it makes it impossible to browse the list. *) >-(* >- sync_action := >- Some >- (fun () -> >- makeFirstUnfinishedVisible pRiThisRound; >- sync_action := None); >-*) >- gtk_sync false; >- return ()) >- | Some _ -> >- return () (* Already processed this one (e.g. merged it) *) >- in >- loop (i + 1) (action :: actions) pRiThisRound >- end else >- actions >- in >- startStats (); >- Lwt_unix.run >- (let actions = loop 0 [] (fun ri -> not (Common.isDeletion ri)) in >- Lwt_util.join actions); >- Lwt_unix.run >- (let actions = loop 0 [] Common.isDeletion in >- Lwt_util.join actions); >- Transport.logFinish (); >- Trace.showTimer t; >- commitUpdates (); >- stopStats (); >- >- let failureList = >- Array.fold_right >- (fun si l -> >- match si.whatHappened with >- Some (Util.Failed err, _) -> >- (si, [err], "transport failure") :: l >- | _ -> >- l) >- !theState [] >- in >- let failureCount = List.length failureList in >- let failures = >- if failureCount = 0 then [] else >- [Printf.sprintf "%d failure%s" >- failureCount (if failureCount = 1 then "" else "s")] >- in >- let partialList = >- Array.fold_right >- (fun si l -> >- match si.whatHappened with >- Some (Util.Succeeded, _) >- when partiallyProblematic si.ri && >- not (problematic si.ri) -> >- let errs = >- match si.ri.replicas with >- Different diff -> diff.errors1 @ diff.errors2 >- | _ -> assert false >- in >- (si, errs, >- "partial transfer (errors during update detection)") :: l >- | _ -> >- l) >- !theState [] >- in >- let partialCount = List.length partialList in >- let partials = >- if partialCount = 0 then [] else >- [Printf.sprintf "%d partially transferred" partialCount] >- in >- let skippedList = >- Array.fold_right >- (fun si l -> >- match si.ri.replicas with >- Problem err -> >- (si, [err], "error during update detection") :: l >- | Different diff when isConflict diff.direction -> >- (si, [], >- if isConflict diff.default_direction then >- "conflict" >- else "skipped") :: l >- | _ -> >- l) >- !theState [] >- in >- let skippedCount = List.length skippedList in >- let skipped = >- if skippedCount = 0 then [] else >- [Printf.sprintf "%d skipped" skippedCount] >- in >- unsynchronizedPaths := >- Some (Safelist.map (fun (si, _, _) -> si.ri.path1) >- (failureList @ partialList @ skippedList), >- []); >- Trace.status >- (Printf.sprintf "Synchronization complete %s" >- (String.concat ", " (failures @ partials @ skipped))); >- displayGlobalProgress 0.; >- >- grSet grRescan true; >- make_interactive toplevelWindow; >- >- let totalCount = failureCount + partialCount + skippedCount in >- if totalCount > 0 then begin >- let format n item sing plur = >- match n with >- 0 -> [] >- | 1 -> [Format.sprintf "one %s%s" item sing] >- | n -> [Format.sprintf "%d %s%s" n item plur] >- in >- let infos = >- format failureCount "failure" "" "s" @ >- format partialCount "partially transferred director" "y" "ies" @ >- format skippedCount "skipped item" "" "s" >- in >- let message = >- (if failureCount = 0 then "The synchronization was successful.\n\n" >- else "") ^ >- "The replicas are not fully synchronized.\n" ^ >- (if totalCount < 2 then "There was" else "There were") ^ >- begin match infos with >- [] -> assert false >- | [x] -> " " ^ x >- | l -> ":\n - " ^ String.concat ";\n - " l >- end ^ >- "." >- in >- summaryBox ~parent:toplevelWindow >- ~title:"Synchronization summary" ~message ~f: >- (fun t -> >- let bullet = "\xe2\x80\xa2 " in >- let layout = Pango.Layout.create t#misc#pango_context#as_context in >- Pango.Layout.set_text layout bullet; >- let (n, _) = Pango.Layout.get_pixel_size layout in >- let path = >- t#buffer#create_tag [`FONT_DESC (Lazy.force fontBold)] in >- let description = >- t#buffer#create_tag [`FONT_DESC (Lazy.force fontItalic)] in >- let errorFirstLine = >- t#buffer#create_tag [`LEFT_MARGIN (n); `INDENT (- n)] in >- let errorNextLines = >- t#buffer#create_tag [`LEFT_MARGIN (2 * n)] in >- List.iter >- (fun (si, errs, desc) -> >- t#buffer#insert ~tags:[path] >- (transcodeFilename (Path.toString si.ri.path1)); >- t#buffer#insert ~tags:[description] >- (" \xe2\x80\x94 " ^ desc ^ "\n"); >- List.iter >- (fun err -> >- let errl = >- Str.split (Str.regexp_string "\n") (transcode err) in >- match errl with >- [] -> >- () >- | f :: rem -> >- t#buffer#insert ~tags:[errorFirstLine] >- (bullet ^ f ^ "\n"); >- List.iter >- (fun n -> >- t#buffer#insert ~tags:[errorNextLines] >- (n ^ "\n")) >- rem) >- errs) >- (failureList @ partialList @ skippedList)) >- end >- >- end in >- >- (********************************************************************* >- Buttons for -->, M, <--, Skip >- *********************************************************************) >- let doActionOnRow f i theSI iter = >- begin match theSI.whatHappened, theSI.ri.replicas with >- None, Different diff -> >- f theSI.ri diff; >- redisplay i theSI iter >- | _ -> >- () >- end >- in >- let doAction f = >- match currentRow () with >- Some (i, si, iter) -> >- doActionOnRow f i si iter; >- nextInteresting () >- | None -> >- currentSelectedIter (fun i si iter -> doActionOnRow f i si iter); >- updateDetails () >- in >- let leftAction _ = >- doAction (fun _ diff -> diff.direction <- Replica2ToReplica1) in >- let rightAction _ = >- doAction (fun _ diff -> diff.direction <- Replica1ToReplica2) in >- let questionAction _ = doAction (fun _ diff -> diff.direction <- Conflict "") in >- let mergeAction _ = doAction (fun _ diff -> diff.direction <- Merge) in >- >- let insert_button (toolbar : #GButton.toolbar) ~stock ~text ~tooltip ~callback () = >- let b = GButton.tool_button ~stock ~label:text ~packing:toolbar#insert () in >- ignore (b#connect#clicked ~callback); >- b#misc#set_tooltip_text tooltip; >- b >- in >- >-(* actionBar#insert_space ();*) >- grAdd grAction >- (insert_button actionBar >- ~stock:`GO_FORWARD >- ~text:"Left to Right" >- ~tooltip:"Propagate selected items\n\ >- from the left replica to the right one" >- ~callback:rightAction ()); >-(* actionBar#insert_space ();*) >- grAdd grAction >- (insert_button actionBar ~text:"Skip" >- ~stock:`NO >- ~tooltip:"Skip selected items" >- ~callback:questionAction ()); >-(* actionBar#insert_space ();*) >- grAdd grAction >- (insert_button actionBar >- ~stock:`GO_BACK >- ~text:"Right to Left" >- ~tooltip:"Propagate selected items\n\ >- from the right replica to the left one" >- ~callback:leftAction ()); >-(* actionBar#insert_space ();*) >- grAdd grAction >- (insert_button actionBar >- ~stock:`ADD >- ~text:"Merge" >- ~tooltip:"Merge selected files" >- ~callback:mergeAction ()); >- >- (********************************************************************* >- Diff / merge buttons >- *********************************************************************) >- let diffCmd () = >- match currentRow () with >- Some (i, item, _) -> >- getLock (fun () -> >- let len = >- match item.ri.replicas with >- Problem _ -> >- Uutil.Filesize.zero >- | Different diff -> >- snd (if !root1IsLocal then diff.rc2 else diff.rc1).size >- in >- item.bytesTransferred <- Uutil.Filesize.zero; >- item.bytesToTransfer <- len; >- initGlobalProgress len; >- startStats (); >- Uicommon.showDiffs item.ri >- (fun title text -> >- messageBox ~title:(transcode title) (transcode text)) >- Trace.status (Uutil.File.ofLine i); >- stopStats (); >- displayGlobalProgress 0.; >- fastRedisplay i) >- | None -> >- () in >- >- actionBar#insert (GButton.separator_tool_item ()); >- grAdd grDiff (insert_button actionBar ~text:"Diff" >- ~stock:`DIALOG_INFO >- ~tooltip:"Compare the two files at each replica" >- ~callback:diffCmd ()); >- >- (********************************************************************* >- Detail button >- *********************************************************************) >-(* actionBar#insert_space ();*) >- grAdd grDetail (insert_button actionBar ~text:"Details" >- ~stock:`INFO >- ~tooltip:"Show detailed information about\n\ >- an item, when available" >- ~callback:showDetCommand ()); >- >- (********************************************************************* >- Quit button >- *********************************************************************) >-(* actionBar#insert_space (); >- ignore (actionBar#insert_button ~text:"Quit" >- ~icon:((GMisc.image ~stock:`QUIT ())#coerce) >- ~tooltip:"Exit Unison" >- ~callback:safeExit ()); >-*) >- >- (********************************************************************* >- go button >- *********************************************************************) >- actionBar#insert (GButton.separator_tool_item ()); >- grAdd grGo >- (insert_button actionBar ~text:"Go" >- (* tooltip:"Go with displayed actions" *) >- ~stock:`EXECUTE >- ~tooltip:"Perform the synchronization" >- ~callback:(fun () -> >- getLock synchronize) ()); >- >- (* Does not quite work: too slow, and Files.copy must be modifed to >- support an interruption without error. *) >- (* >- ignore (actionBar#insert_button ~text:"Stop" >- ~icon:((GMisc.image ~stock:`STOP ())#coerce) >- ~tooltip:"Exit Unison" >- ~callback:Abort.all ()); >- *) >- >- (********************************************************************* >- Rescan button >- *********************************************************************) >- let updateFromProfile = ref (fun () -> ()) in >- >- let prepDebug () = >- if Sys.os_type = "Win32" then >- (* As a side-effect, this allocates a console if the process doesn't >- have one already. This call is here only for the side-effect, >- because debugging output is produced on stderr and the GUI will >- crash if there is no stderr. *) >- try ignore (System.terminalStateFunctions ()) >- with Unix.Unix_error _ -> () >- in >- >- let loadProfile p reload = >- debug (fun()-> Util.msg "Loading profile %s..." p); >- Trace.status "Loading profile"; >- unsynchronizedPaths := None; >- Uicommon.initPrefs ~profileName:p >- ~displayWaitMessage:(fun () -> if not reload then displayWaitMessage ()) >- ~getFirstRoot ~getSecondRoot ~prepDebug ~termInteract (); >- !updateFromProfile () >- in >- >- let reloadProfile () = >- let n = >- match !Prefs.profileName with >- None -> assert false >- | Some n -> n >- in >- clearMainWindow (); >- if not (Prefs.profileUnchanged ()) then loadProfile n true >- else Uicommon.refreshConnection ~displayWaitMessage ~termInteract >- in >- >- let detectCmd () = >- getLock detectUpdatesAndReconcile; >- updateDetails (); >- if Prefs.read Globals.batch then begin >- Prefs.set Globals.batch false; synchronize() >- end >- in >-(* actionBar#insert_space ();*) >- grAdd grRescan >- (insert_button actionBar ~text:"Rescan" >- ~stock:`REFRESH >- ~tooltip:"Check for updates" >- ~callback: (fun () -> reloadProfile(); detectCmd()) ()); >- >- (********************************************************************* >- Profile change button >- *********************************************************************) >- actionBar#insert (GButton.separator_tool_item ()); >- let profileChange _ = >- match getProfile false with >- None -> () >- | Some p -> clearMainWindow (); loadProfile p false; detectCmd () >- in >- grAdd grRescan (insert_button actionBar ~text:"Change Profile" >- ~stock:`OPEN >- ~tooltip:"Select a different profile" >- ~callback:profileChange ()); >- >- (********************************************************************* >- Keyboard commands >- *********************************************************************) >- ignore >- (mainWindow#event#connect#key_press ~callback: >- begin fun ev -> >- let key = GdkEvent.Key.keyval ev in >- if key = GdkKeysyms._Left then begin >- leftAction (); GtkSignal.stop_emit (); true >- end else if key = GdkKeysyms._Right then begin >- rightAction (); GtkSignal.stop_emit (); true >- end else >- false >- end); >- >- (********************************************************************* >- Action menu >- *********************************************************************) >- let buildActionMenu init = >- let withDelayedUpdates f x = >- delayUpdates := true; >- f x; >- delayUpdates := false; >- updateDetails () in >- let actionMenu = replace_submenu "_Actions" actionItem in >- grAdd grRescan >- (actionMenu#add_image_item >- ~callback:(fun _ -> withDelayedUpdates mainWindow#selection#select_all ()) >- ~image:((GMisc.image ~stock:`SELECT_ALL ~icon_size:`MENU ())#coerce) >- ~modi:[`CONTROL] ~key:GdkKeysyms._A >- "Select _All"); >- grAdd grRescan >- (actionMenu#add_item >- ~callback:(fun _ -> withDelayedUpdates mainWindow#selection#unselect_all ()) >- ~modi:[`SHIFT; `CONTROL] ~key:GdkKeysyms._A >- "_Deselect All"); >- >- ignore (actionMenu#add_separator ()); >- >- let (loc1, loc2) = >- if init then ("", "") else >- let (root1,root2) = Globals.roots () in >- (root2hostname root1, root2hostname root2) >- in >- let def_descr = "Left to Right" in >- let descr = >- if init || loc1 = loc2 then def_descr else >- Printf.sprintf "from %s to %s" loc1 loc2 in >- let left = >- actionMenu#add_image_item ~key:GdkKeysyms._greater ~callback:rightAction >- ~image:((GMisc.image ~stock:`GO_FORWARD ~icon_size:`MENU ())#coerce) >- ~name:("Propagate " ^ def_descr) ("Propagate " ^ descr) in >- grAdd grAction left; >- left#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._greater; >- left#add_accelerator ~group:accel_group GdkKeysyms._period; >- >- let def_descl = "Right to Left" in >- let descl = >- if init || loc1 = loc2 then def_descl else >- Printf.sprintf "from %s to %s" >- (Unicode.protect loc2) (Unicode.protect loc1) in >- let right = >- actionMenu#add_image_item ~key:GdkKeysyms._less ~callback:leftAction >- ~image:((GMisc.image ~stock:`GO_BACK ~icon_size:`MENU ())#coerce) >- ~name:("Propagate " ^ def_descl) ("Propagate " ^ descl) in >- grAdd grAction right; >- right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._less; >- right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._comma; >- >- let skip = >- actionMenu#add_image_item ~key:GdkKeysyms._slash ~callback:questionAction >- ~image:((GMisc.image ~stock:`NO ~icon_size:`MENU ())#coerce) >- "Do _Not Propagate Changes" in >- grAdd grAction skip; >- skip#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._minus; >- >- let merge = >- actionMenu#add_image_item ~key:GdkKeysyms._m ~callback:mergeAction >- ~image:((GMisc.image ~stock:`ADD ~icon_size:`MENU ())#coerce) >- "_Merge the Files" in >- grAdd grAction merge; >- (* merge#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._m; *) >- >- (* Override actions *) >- ignore (actionMenu#add_separator ()); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> >- Recon.setDirection ri `Replica1ToReplica2 `Prefer)) >- "Resolve Conflicts in Favor of First Root"); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> >- Recon.setDirection ri `Replica2ToReplica1 `Prefer)) >- "Resolve Conflicts in Favor of Second Root"); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> >- Recon.setDirection ri `Newer `Prefer)) >- "Resolve Conflicts in Favor of Most Recently Modified"); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> >- Recon.setDirection ri `Older `Prefer)) >- "Resolve Conflicts in Favor of Least Recently Modified"); >- ignore (actionMenu#add_separator ()); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> Recon.setDirection ri `Newer `Force)) >- "Force Newer Files to Replace Older Ones"); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> Recon.setDirection ri `Older `Force)) >- "Force Older Files to Replace Newer Ones"); >- ignore (actionMenu#add_separator ()); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> Recon.revertToDefaultDirection ri)) >- "_Revert to Unison's Recommendations"); >- grAdd grAction >- (actionMenu#add_item >- ~callback:(fun () -> >- doAction (fun ri _ -> Recon.setDirection ri `Merge `Force)) >- "Revert to the Merging Default, if Available"); >- >- (* Diff *) >- ignore (actionMenu#add_separator ()); >- grAdd grDiff (actionMenu#add_image_item ~key:GdkKeysyms._d ~callback:diffCmd >- ~image:((GMisc.image ~stock:`DIALOG_INFO ~icon_size:`MENU ())#coerce) >- "Show _Diffs"); >- >- (* Details *) >- grAdd grDetail >- (actionMenu#add_image_item ~key:GdkKeysyms._i ~callback:showDetCommand >- ~image:((GMisc.image ~stock:`INFO ~icon_size:`MENU ())#coerce) >- "Detailed _Information") >- >- in >- buildActionMenu true; >- >- (********************************************************************* >- Synchronization menu >- *********************************************************************) >- >- grAdd grGo >- (fileMenu#add_image_item ~key:GdkKeysyms._g >- ~image:(GMisc.image ~stock:`EXECUTE ~icon_size:`MENU () :> GObj.widget) >- ~callback:(fun () -> getLock synchronize) >- "_Go"); >- grAdd grRescan >- (fileMenu#add_image_item ~key:GdkKeysyms._r >- ~image:(GMisc.image ~stock:`REFRESH ~icon_size:`MENU () :> GObj.widget) >- ~callback:(fun () -> reloadProfile(); detectCmd()) >- "_Rescan"); >- grAdd grRescan >- (fileMenu#add_item ~key:GdkKeysyms._a >- ~callback:(fun () -> >- reloadProfile(); >- Prefs.set Globals.batch true; >- detectCmd()) >- "_Detect Updates and Proceed (Without Waiting)"); >- grAdd grRescan >- (fileMenu#add_item ~key:GdkKeysyms._f >- ~callback:( >- fun () -> >- let rec loop i acc = >- if i >= Array.length (!theState) then acc else >- let notok = >- (match !theState.(i).whatHappened with >- None-> true >- | Some(Util.Failed _, _) -> true >- | Some(Util.Succeeded, _) -> false) >- || match !theState.(i).ri.replicas with >- Problem _ -> true >- | Different diff -> isConflict diff.direction in >- if notok then loop (i+1) (i::acc) >- else loop (i+1) (acc) in >- let failedindices = loop 0 [] in >- let failedpaths = >- Safelist.map (fun i -> !theState.(i).ri.path1) failedindices in >- debug (fun()-> Util.msg "Rescaning with paths = %s\n" >- (String.concat ", " (Safelist.map >- (fun p -> "'"^(Path.toString p)^"'") >- failedpaths))); >- let paths = Prefs.read Globals.paths in >- let confirmBigDeletes = Prefs.read Globals.confirmBigDeletes in >- Prefs.set Globals.paths failedpaths; >- Prefs.set Globals.confirmBigDeletes false; >- (* Modifying global paths does not play well with filesystem >- monitoring, so we disable it. *) >- unsynchronizedPaths := None; >- detectCmd(); >- Prefs.set Globals.paths paths; >- Prefs.set Globals.confirmBigDeletes confirmBigDeletes; >- unsynchronizedPaths := None) >- "Re_check Unsynchronized Items"); >- >- ignore (fileMenu#add_separator ()); >- >- grAdd grRescan >- (fileMenu#add_image_item ~key:GdkKeysyms._p >- ~callback:(fun _ -> >- match getProfile false with >- None -> () >- | Some(p) -> clearMainWindow (); loadProfile p false; detectCmd ()) >- ~image:(GMisc.image ~stock:`OPEN ~icon_size:`MENU () :> GObj.widget) >- "Change _Profile..."); >- >- let fastProf name key = >- grAdd grRescan >- (fileMenu#add_item ~key:key >- ~callback:(fun _ -> >- if System.file_exists (Prefs.profilePathname name) then begin >- Trace.status ("Loading profile " ^ name); >- loadProfile name false; detectCmd () >- end else >- Trace.status ("Profile " ^ name ^ " not found")) >- ("Select profile " ^ name)) in >- >- let fastKeysyms = >- [| GdkKeysyms._0; GdkKeysyms._1; GdkKeysyms._2; GdkKeysyms._3; >- GdkKeysyms._4; GdkKeysyms._5; GdkKeysyms._6; GdkKeysyms._7; >- GdkKeysyms._8; GdkKeysyms._9 |] in >- >- Array.iteri >- (fun i v -> match v with >- None -> () >- | Some(profile, info) -> >- fastProf profile fastKeysyms.(i)) >- Uicommon.profileKeymap; >- >- ignore (fileMenu#add_separator ()); >- ignore (fileMenu#add_item >- ~callback:(fun _ -> statWin#show ()) "Show _Statistics"); >- >- ignore (fileMenu#add_separator ()); >- let quit = >- fileMenu#add_image_item >- ~key:GdkKeysyms._q ~callback:safeExit >- ~image:((GMisc.image ~stock:`QUIT ~icon_size:`MENU ())#coerce) >- "_Quit" >- in >- quit#add_accelerator ~group:accel_group ~modi:[`CONTROL] GdkKeysyms._q; >- >- (********************************************************************* >- Expert menu >- *********************************************************************) >- if Prefs.read Uicommon.expert then begin >- let (expertMenu, _) = add_submenu "Expert" in >- >- let addDebugToggle modname = >- ignore (expertMenu#add_check_item ~active:(Trace.enabled modname) >- ~callback:(fun b -> Trace.enable modname b) >- ("Debug '" ^ modname ^ "'")) in >- >- addDebugToggle "all"; >- addDebugToggle "verbose"; >- addDebugToggle "update"; >- >- ignore (expertMenu#add_separator ()); >- ignore (expertMenu#add_item >- ~callback:(fun () -> >- Printf.fprintf stderr "\nGC stats now:\n"; >- Gc.print_stat stderr; >- Printf.fprintf stderr "\nAfter major collection:\n"; >- Gc.full_major(); Gc.print_stat stderr; >- flush stderr) >- "Show memory/GC stats") >- end; >- >- (********************************************************************* >- Finish up >- *********************************************************************) >- grDisactivateAll (); >- >- updateFromProfile := >- (fun () -> >- displayNewProfileLabel (); >- setMainWindowColumnHeaders (Uicommon.roots2string ()); >- buildActionMenu false); >- >- >- ignore (toplevelWindow#event#connect#delete ~callback: >- (fun _ -> safeExit (); true)); >- toplevelWindow#show (); >- fun () -> >- !updateFromProfile (); >- mainWindow#misc#grab_focus (); >- detectCmd () >- >- >-(********************************************************************* >- STARTUP >- *********************************************************************) >- >-let start _ = >- begin try >- (* Initialize the GTK library *) >- ignore (GMain.Main.init ()); >- >- Util.warnPrinter := >- Some (fun msg -> warnBox ~parent:(toplevelWindow ()) "Warning" msg); >- >- GtkSignal.user_handler := >- (fun exn -> >- match exn with >- Util.Transient(s) | Util.Fatal(s) -> fatalError s >- | exn -> fatalError (Uicommon.exn2string exn)); >- >- (* Ask the Remote module to call us back at regular intervals during >- long network operations. *) >- let rec tick () = >- gtk_sync true; >- Lwt_unix.sleep 0.05 >>= tick >- in >- ignore_result (tick ()); >- >- let prepDebug () = >- if Sys.os_type = "Win32" then >- (* As a side-effect, this allocates a console if the process doesn't >- have one already. This call is here only for the side-effect, >- because debugging output is produced on stderr and the GUI will >- crash if there is no stderr. *) >- try ignore (System.terminalStateFunctions ()) >- with Unix.Unix_error _ -> () >- in >- >- Os.createUnisonDir(); >- Uicommon.scanProfiles(); >- let detectCmd = createToplevelWindow() in >- >- Uicommon.uiInit >- ~prepDebug >- ~reportError:fatalError >- ~tryAgainOrQuit >- ~displayWaitMessage >- ~getProfile:(fun () -> getProfile true) >- ~getFirstRoot >- ~getSecondRoot >- ~termInteract >- (); >- detectCmd (); >- >- (* Display the ui *) >-(*JV: not useful, as Unison does not handle any signal >- ignore (GMain.Timeout.add 500 (fun _ -> true)); >- (* Hack: this allows signals such as SIGINT to be >- handled even when Gtk is waiting for events *) >-*) >- GMain.Main.main () >- with >- Util.Transient(s) | Util.Fatal(s) -> fatalError s >- | exn -> fatalError (Uicommon.exn2string exn) >- end >- >-end (* module Private *) >- >- >-(********************************************************************* >- UI SELECTION >- *********************************************************************) >- >-module Body : Uicommon.UI = struct >- >-let start = function >- Uicommon.Text -> Uitext.Body.start Uicommon.Text >- | Uicommon.Graphic -> >- let displayAvailable = >- Util.osType = `Win32 >- || >- try System.getenv "DISPLAY" <> "" with Not_found -> false >- in >- if displayAvailable then Private.start Uicommon.Graphic >- else >- Util.warn "DISPLAY not set or empty; starting the Text UI\n"; >- Uitext.Body.start Uicommon.Text >- >-let defaultUi = Uicommon.Graphic >- >-end (* module Body *) >Index: unison-2.51.5/src/uigtk3.ml >=================================================================== >--- /dev/null >+++ unison-2.51.5/src/uigtk3.ml >@@ -0,0 +1,4239 @@ >+(* Unison file synchronizer: src/uigtk3.ml *) >+(* Copyright 1999-2020, Benjamin C. Pierce >+ >+ This program is free software: you can redistribute it and/or modify >+ it under the terms of the GNU General Public License as published by >+ the Free Software Foundation, either version 3 of the License, or >+ (at your option) any later version. >+ >+ This program is distributed in the hope that it will be useful, >+ but WITHOUT ANY WARRANTY; without even the implied warranty of >+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the >+ GNU General Public License for more details. >+ >+ You should have received a copy of the GNU General Public License >+ along with this program. If not, see <http://www.gnu.org/licenses/>. >+*) >+ >+ >+open Common >+open Lwt >+ >+module Private = struct >+ >+let debug = Trace.debug "ui" >+ >+let myNameCapitalized = String.capitalize_ascii Uutil.myName >+ >+(********************************************************************** >+ LOW-LEVEL STUFF >+ **********************************************************************) >+ >+(********************************************************************** >+ Some message strings (build them here because they look ugly in the >+ middle of other code. >+ **********************************************************************) >+ >+let tryAgainMessage = >+ Printf.sprintf >+"You can use %s to synchronize a local directory with another local directory, >+or with a remote directory. >+ >+Please enter the first (local) directory that you want to synchronize." >+myNameCapitalized >+ >+(* ---- *) >+ >+let helpmessage = Printf.sprintf >+"%s can synchronize a local directory with another local directory, or with >+a directory on a remote machine. >+ >+To synchronize with a local directory, just enter the file name. >+ >+To synchronize with a remote directory, you must first choose a protocol >+that %s will use to connect to the remote machine. Each protocol has >+different requirements: >+ >+1) To synchronize using SSH, there must be an SSH client installed on >+this machine and an SSH server installed on the remote machine. You >+must enter the host to connect to, a user name (if different from >+your user name on this machine), and the directory on the remote machine >+(relative to your home directory on that machine). >+ >+2) To synchronize using RSH, there must be an RSH client installed on >+this machine and an RSH server installed on the remote machine. You >+must enter the host to connect to, a user name (if different from >+your user name on this machine), and the directory on the remote machine >+(relative to your home directory on that machine). >+ >+3) To synchronize using %s's socket protocol, there must be a %s >+server running on the remote machine, listening to the port that you >+specify here. (Use \"%s -socket xxx\" on the remote machine to >+start the %s server.) You must enter the host, port, and the directory >+on the remote machine (relative to the working directory of the >+%s server running on that machine)." >+myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized >+ >+(********************************************************************** >+ Font preferences >+ **********************************************************************) >+ >+let fontMonospace = lazy (Pango.Font.from_string "monospace") >+let fontBold = lazy (Pango.Font.from_string "bold") >+let fontItalic = lazy (Pango.Font.from_string "italic") >+ >+(********************************************************************** >+ Unison icon >+ **********************************************************************) >+ >+(* This does not work with the current version of Lablgtk, due to a bug >+let icon = >+ GdkPixbuf.from_data ~width:48 ~height:48 ~has_alpha:true >+ (Gpointer.region_of_bytes Pixmaps.icon_data) >+*) >+let icon = >+ let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in >+ let pxs = GdkPixbuf.get_pixels p in >+ (* This little hack is here to support compiling with lablgtk versions both >+ < 2.18.6 and >= 2.18.6 *) >+ String.iteri (fun i c -> Gpointer.set_byte pxs ~pos:i (Char.code c)) Pixmaps.icon_data; >+ p >+ >+let leftPtrWatch = >+ lazy (Gdk.Cursor.create `WATCH) >+ >+let make_busy w = >+ if Util.osType <> `Win32 then >+ Gdk.Window.set_cursor w#misc#window (Lazy.force leftPtrWatch) >+let make_interactive w = >+ if Util.osType <> `Win32 then >+ (* HACK: setting the cursor to NULL restore the default cursor *) >+ Gdk.Window.set_cursor w#misc#window (Obj.magic Gpointer.boxed_null) >+ >+(********************************************************************* >+ UI state variables >+ *********************************************************************) >+ >+type stateItem = { mutable ri : reconItem; >+ mutable bytesTransferred : Uutil.Filesize.t; >+ mutable bytesToTransfer : Uutil.Filesize.t; >+ mutable whatHappened : (Util.confirmation * string option) option} >+let theState = ref [||] >+let unsynchronizedPaths = ref None >+ >+(* ---- *) >+ >+let theToplevelWindow = ref None >+let setToplevelWindow w = theToplevelWindow := Some w >+let toplevelWindow () = >+ match !theToplevelWindow with >+ Some w -> w >+ | None -> raise (Util.Fatal "Main window not initialized; check your DISPLAY setup") >+ >+(********************************************************************* >+ Lock management >+ *********************************************************************) >+ >+let busy = ref false >+ >+let getLock f = >+ if !busy then >+ Trace.status "Synchronizer is busy, please wait.." >+ else begin >+ busy := true; f (); busy := false >+ end >+ >+(********************************************************************** >+ Miscellaneous >+ **********************************************************************) >+ >+let sync_action = ref None >+ >+let last = ref (0.) >+ >+let gtk_sync forced = >+ let t = Unix.gettimeofday () in >+ if !last = 0. || forced || t -. !last > 0.05 then begin >+ last := t; >+ begin match !sync_action with >+ Some f -> f () >+ | None -> () >+ end; >+ while Glib.Main.iteration false do () done >+ end >+ >+(********************************************************************** >+ CHARACTER SET TRANSCODING >+***********************************************************************) >+ >+(* Transcodage from Microsoft Windows Codepage 1252 to Unicode *) >+ >+(* Unison currently uses the "ASCII" Windows filesystem API. With >+ this API, filenames are encoded using a proprietary character >+ encoding. This encoding depends on the Windows setup, but in >+ Western Europe, the Windows Codepage 1252 is usually used. >+ GTK, on the other hand, uses the UTF-8 encoding. This code perform >+ the translation from Codepage 1252 to UTF-8. A call to [transcode] >+ should be wrapped around every string below that might contain >+ non-ASCII characters. *) >+ >+let code = >+ [| 0x0020; 0x0001; 0x0002; 0x0003; 0x0004; 0x0005; 0x0006; 0x0007; >+ 0x0008; 0x0009; 0x000A; 0x000B; 0x000C; 0x000D; 0x000E; 0x000F; >+ 0x0010; 0x0011; 0x0012; 0x0013; 0x0014; 0x0015; 0x0016; 0x0017; >+ 0x0018; 0x0019; 0x001A; 0x001B; 0x001C; 0x001D; 0x001E; 0x001F; >+ 0x0020; 0x0021; 0x0022; 0x0023; 0x0024; 0x0025; 0x0026; 0x0027; >+ 0x0028; 0x0029; 0x002A; 0x002B; 0x002C; 0x002D; 0x002E; 0x002F; >+ 0x0030; 0x0031; 0x0032; 0x0033; 0x0034; 0x0035; 0x0036; 0x0037; >+ 0x0038; 0x0039; 0x003A; 0x003B; 0x003C; 0x003D; 0x003E; 0x003F; >+ 0x0040; 0x0041; 0x0042; 0x0043; 0x0044; 0x0045; 0x0046; 0x0047; >+ 0x0048; 0x0049; 0x004A; 0x004B; 0x004C; 0x004D; 0x004E; 0x004F; >+ 0x0050; 0x0051; 0x0052; 0x0053; 0x0054; 0x0055; 0x0056; 0x0057; >+ 0x0058; 0x0059; 0x005A; 0x005B; 0x005C; 0x005D; 0x005E; 0x005F; >+ 0x0060; 0x0061; 0x0062; 0x0063; 0x0064; 0x0065; 0x0066; 0x0067; >+ 0x0068; 0x0069; 0x006A; 0x006B; 0x006C; 0x006D; 0x006E; 0x006F; >+ 0x0070; 0x0071; 0x0072; 0x0073; 0x0074; 0x0075; 0x0076; 0x0077; >+ 0x0078; 0x0079; 0x007A; 0x007B; 0x007C; 0x007D; 0x007E; 0x007F; >+ 0x20AC; 0x1234; 0x201A; 0x0192; 0x201E; 0x2026; 0x2020; 0x2021; >+ 0x02C6; 0x2030; 0x0160; 0x2039; 0x0152; 0x1234; 0x017D; 0x1234; >+ 0x1234; 0x2018; 0x2019; 0x201C; 0x201D; 0x2022; 0x2013; 0x2014; >+ 0x02DC; 0x2122; 0x0161; 0x203A; 0x0153; 0x1234; 0x017E; 0x0178; >+ 0x00A0; 0x00A1; 0x00A2; 0x00A3; 0x00A4; 0x00A5; 0x00A6; 0x00A7; >+ 0x00A8; 0x00A9; 0x00AA; 0x00AB; 0x00AC; 0x00AD; 0x00AE; 0x00AF; >+ 0x00B0; 0x00B1; 0x00B2; 0x00B3; 0x00B4; 0x00B5; 0x00B6; 0x00B7; >+ 0x00B8; 0x00B9; 0x00BA; 0x00BB; 0x00BC; 0x00BD; 0x00BE; 0x00BF; >+ 0x00C0; 0x00C1; 0x00C2; 0x00C3; 0x00C4; 0x00C5; 0x00C6; 0x00C7; >+ 0x00C8; 0x00C9; 0x00CA; 0x00CB; 0x00CC; 0x00CD; 0x00CE; 0x00CF; >+ 0x00D0; 0x00D1; 0x00D2; 0x00D3; 0x00D4; 0x00D5; 0x00D6; 0x00D7; >+ 0x00D8; 0x00D9; 0x00DA; 0x00DB; 0x00DC; 0x00DD; 0x00DE; 0x00DF; >+ 0x00E0; 0x00E1; 0x00E2; 0x00E3; 0x00E4; 0x00E5; 0x00E6; 0x00E7; >+ 0x00E8; 0x00E9; 0x00EA; 0x00EB; 0x00EC; 0x00ED; 0x00EE; 0x00EF; >+ 0x00F0; 0x00F1; 0x00F2; 0x00F3; 0x00F4; 0x00F5; 0x00F6; 0x00F7; >+ 0x00F8; 0x00F9; 0x00FA; 0x00FB; 0x00FC; 0x00FD; 0x00FE; 0x00FF |] >+ >+let rec transcodeRec buf s i l = >+ if i < l then begin >+ let c = code.(Char.code s.[i]) in >+ if c < 0x80 then >+ Buffer.add_char buf (Char.chr c) >+ else if c < 0x800 then begin >+ Buffer.add_char buf (Char.chr (c lsr 6 + 0xC0)); >+ Buffer.add_char buf (Char.chr (c land 0x3f + 0x80)) >+ end else if c < 0x10000 then begin >+ Buffer.add_char buf (Char.chr (c lsr 12 + 0xE0)); >+ Buffer.add_char buf (Char.chr ((c lsr 6) land 0x3f + 0x80)); >+ Buffer.add_char buf (Char.chr (c land 0x3f + 0x80)) >+ end; >+ transcodeRec buf s (i + 1) l >+ end >+ >+let transcodeDoc s = >+ let buf = Buffer.create 1024 in >+ transcodeRec buf s 0 (String.length s); >+ Buffer.contents buf >+ >+(****) >+ >+let escapeMarkup s = Glib.Markup.escape_text s >+ >+let transcodeFilename s = >+ if Prefs.read Case.unicodeEncoding then >+ Unicode.protect s >+ else if Util.osType = `Win32 then transcodeDoc s else >+ try >+ Glib.Convert.filename_to_utf8 s >+ with Glib.Convert.Error _ -> >+ Unicode.protect s >+ >+let transcode s = >+ if Prefs.read Case.unicodeEncoding then >+ Unicode.protect s >+ else >+ try >+ Glib.Convert.locale_to_utf8 s >+ with Glib.Convert.Error _ -> >+ Unicode.protect s >+ >+(********************************************************************** >+ USEFUL LOW-LEVEL WIDGETS >+ **********************************************************************) >+ >+class scrolled_text ?editable ?shadow_type ?word_wrap >+ ~width ~height ?packing ?show >+ () = >+ let sw = >+ GBin.scrolled_window ?packing ~show:false >+ ?shadow_type ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () >+ in >+ let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in >+ object >+ inherit GObj.widget_full sw#as_widget >+ method text = text >+ method insert s = text#buffer#set_text s; >+ method show () = sw#misc#show () >+ initializer >+ text#misc#set_size_chars ~height ~width (); >+ if show <> Some false then sw#misc#show () >+ end >+ >+(* ------ *) >+ >+(* Display a message in a window and wait for the user >+ to hit the button. *) >+let okBox ~parent ~title ~typ ~message = >+ let t = >+ GWindow.message_dialog >+ ~parent ~title ~message_type:typ ~message ~modal:true >+ ~buttons:GWindow.Buttons.ok () in >+ ignore (t#run ()); t#destroy () >+ >+(* ------ *) >+ >+let primaryText msg = >+ Printf.sprintf "<span weight=\"bold\" size=\"larger\">%s</span>" >+ (escapeMarkup msg) >+ >+(* twoBox: Display a message in a window and wait for the user >+ to hit one of two buttons. Return true if the first button is >+ chosen, false if the second button is chosen. *) >+let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message = >+ let t = >+ GWindow.dialog ~parent ~border_width:6 ~modal:true >+ ~resizable:false () in >+ t#vbox#set_spacing 12; >+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >+ ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG >+ ~yalign:0. ~packing:h1#pack ()); >+ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >+ ignore (GMisc.label >+ ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message) >+ ~selectable:true ~yalign:0. ~packing:v1#add ()); >+ t#add_button_stock bstock `NO; >+ t#add_button_stock astock `YES; >+ t#set_default_response `NO; >+ t#show(); >+ let res = t#run () in >+ t#destroy (); >+ res = `YES >+ >+(* ------ *) >+ >+(* Avoid recursive invocations of the function below (a window receives >+ delete events even when it is not sensitive) *) >+let inExit = ref false >+ >+let doExit () = Lwt_unix.run (Update.unlockArchives ()); exit 0 >+ >+let safeExit () = >+ if not !inExit then begin >+ inExit := true; >+ if not !busy then exit 0 else >+ if twoBox ~parent:(toplevelWindow ()) ~title:"Premature exit" >+ ~astock:`YES ~bstock:`NO >+ "Unison is working, exit anyway ?" >+ then exit 0; >+ inExit := false >+ end >+ >+(* ------ *) >+ >+(* warnBox: Display a warning message in a window and wait (unless >+ we're in batch mode) for the user to hit "OK" or "Exit". *) >+let warnBox ~parent title message = >+ let message = transcode message in >+ if Prefs.read Globals.batch then begin >+ (* In batch mode, just pop up a window and go ahead *) >+ let t = >+ GWindow.dialog ~parent >+ ~border_width:6 ~modal:true ~resizable:false () in >+ t#vbox#set_spacing 12; >+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >+ ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG >+ ~yalign:0. ~packing:h1#pack ()); >+ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >+ ignore (GMisc.label ~markup:(primaryText title ^ "\n\n" ^ >+ escapeMarkup message) >+ ~selectable:true ~yalign:0. ~packing:v1#add ()); >+ t#add_button_stock `CLOSE `CLOSE; >+ t#set_default_response `CLOSE; >+ ignore (t#connect#response ~callback:(fun _ -> t#destroy ())); >+ t#show () >+ end else begin >+ inExit := true; >+ let ok = >+ twoBox ~parent:(toplevelWindow ()) ~title ~astock:`OK ~bstock:`QUIT >+ message in >+ if not(ok) then doExit (); >+ inExit := false >+ end >+ >+(****) >+ >+let accel_paths = Hashtbl.create 17 >+let underscore_re = Str.regexp_string "_" >+class ['a] gMenuFactory >+ ?(accel_group=GtkData.AccelGroup.create ()) >+ ?(accel_path="<DEFAULT ROOT>/") >+ ?(accel_modi=[`CONTROL]) >+ ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) = >+ object (self) >+ val menu_shell : #GMenu.menu_shell = menu_shell >+ val group = accel_group >+ val m = accel_modi >+ val flags = (accel_flags:Gtk.Tags.accel_flag list) >+ val accel_path = accel_path >+ method menu = menu_shell >+ method accel_group = group >+ method accel_path = accel_path >+ method private bind >+ ?(modi=m) ?key ?callback label ?(name=label) (item : GMenu.menu_item) = >+ menu_shell#append item; >+ let accel_path = accel_path ^ name in >+ let accel_path = Str.global_replace underscore_re "" accel_path in >+ (* Default accel path value *) >+ if not (Hashtbl.mem accel_paths accel_path) then begin >+ Hashtbl.add accel_paths accel_path (); >+ GtkData.AccelMap.add_entry accel_path ?key ~modi >+ end; >+ (* Register this accel path *) >+ GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group; >+ Gaux.may callback ~f:(fun callback -> item#connect#activate ~callback) >+ method add_item ?key ?modi ?callback ?submenu label = >+ let item = GMenu.menu_item ~use_mnemonic:true ~label () in >+ self#bind ?modi ?key ?callback label item; >+ Gaux.may (submenu : GMenu.menu option) ~f:item#set_submenu; >+ item >+ method add_image_item ?(image : GObj.widget option) >+ ?modi ?key ?callback ?stock ?name label = >+ (* GTK 3 does not provide image menu items (there is a way to >+ manually create a workaround but that does not work with >+ lablgtk. Let's create a regular menu item instead. *) >+ let item = >+ GMenu.menu_item ~use_mnemonic:true ~label () in >+ match stock with >+ | None -> >+ self#bind ?modi ?key ?callback label ?name item; >+ item >+ | Some s -> >+ try >+ let st = GtkStock.Item.lookup s in >+ self#bind >+ ?modi ?key:(if st.GtkStock.keyval=0 then key else None) >+ ?callback label ?name item; >+ item >+ with Not_found -> item >+ >+ method add_check_item ?active ?modi ?key ?callback label = >+ let item = GMenu.check_menu_item ~label ~use_mnemonic:true ?active () in >+ self#bind label ?modi ?key >+ ?callback:(Gaux.may_map callback ~f:(fun f () -> f item#active)) >+ (item : GMenu.check_menu_item :> GMenu.menu_item); >+ item >+ method add_separator () = GMenu.separator_item ~packing:menu_shell#append () >+ method add_submenu label = >+ let item = GMenu.menu_item ~use_mnemonic:true ~label () in >+ self#bind label item; >+ (GMenu.menu ~packing:item#set_submenu (), item) >+ method replace_submenu (item : GMenu.menu_item) = >+ GMenu.menu ~packing:item#set_submenu () >+end >+ >+(********************************************************************** >+ HIGHER-LEVEL WIDGETS >+***********************************************************************) >+ >+(*class stats width height = >+ let pixmap = GDraw.pixmap ~width ~height () in >+ let area = >+ pixmap#set_foreground `WHITE; >+ pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height (); >+ GMisc.pixmap pixmap ~width ~height ~xpad:4 ~ypad:8 () >+ in >+ object (self) >+ inherit GObj.widget_full area#as_widget >+ val mutable maxim = ref 0. >+ val mutable scale = ref 1. >+ val mutable min_scale = 1. >+ val values = Array.make width 0. >+ val mutable active = false >+ >+ method redraw () = >+ scale := min_scale; >+ while !maxim > !scale do >+ scale := !scale *. 1.5 >+ done; >+ pixmap#set_foreground `WHITE; >+ pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height (); >+ pixmap#set_foreground `BLACK; >+ for i = 0 to width - 1 do >+ self#rect i values.(max 0 (i - 1)) values.(i) >+ done >+ >+ method activate a = active <- a; if a then self#redraw () >+ >+ method scale h = truncate ((float height) *. h /. !scale) >+ >+ method private rect i v' v = >+ let h = self#scale v in >+ let h' = self#scale v' in >+ let h1 = min h' h in >+ let h2 = max h' h in >+ pixmap#set_foreground `BLACK; >+ pixmap#rectangle >+ ~filled:true ~x:i ~y:(height - h1) ~width:1 ~height:h1 (); >+ for h = h1 + 1 to h2 do >+ let v = truncate (65535. *. (float (h - h1) /. float (h2 - h1))) in >+ let v = (v / 4096) * 4096 in (* Only use 16 gray levels *) >+ pixmap#set_foreground (`RGB (v, v, v)); >+ pixmap#rectangle >+ ~filled:true ~x:i ~y:(height - h) ~width:1 ~height:1 (); >+ done >+ >+ method push v = >+ let need_max = values.(0) = !maxim in >+ for i = 0 to width - 2 do >+ values.(i) <- values.(i + 1) >+ done; >+ values.(width - 1) <- v; >+ if need_max then begin >+ maxim := 0.; >+ for i = 0 to width - 1 do maxim := max !maxim values.(i) done >+ end else >+ maxim := max !maxim v; >+ if active then begin >+ let need_resize = >+ !maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in >+ if need_resize then >+ self#redraw () >+ else begin >+ pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap); >+ pixmap#set_foreground `WHITE; >+ pixmap#rectangle >+ ~filled:true ~x:(width - 1) ~y:0 ~width:1 ~height (); >+ self#rect (width - 1) values.(width - 2) values.(width - 1) >+ end; >+ area#misc#draw None >+ end >+ end >+*) >+let clientWritten = ref 0. >+let serverWritten = ref 0. >+let emitRate2 = ref 0. >+let receiveRate2 = ref 0. >+ >+let rate2str v = >+ if v > 9.9e3 then begin >+ if v > 9.9e6 then >+ Format.sprintf "%1.0f MiB/s" (v /. 1e6) >+ else if v > 999e3 then >+ Format.sprintf "%1.1f MiB/s" (v /. 1e6) >+ else >+ Format.sprintf "%1.0f KiB/s" (v /. 1e3) >+ end else begin >+ if v > 990. then >+ Format.sprintf "%1.1f KiB/s" (v /. 1e3) >+ else if v > 99. then >+ Format.sprintf "%1.2f KiB/s" (v /. 1e3) >+ else >+ " " >+ end >+ >+let mib = 1024. *. 1024. >+let kib2str v = >+ if v > 100_000_000. then >+ Format.sprintf "%.0f MiB" (v /. mib) >+ else if v > 1_000_000. then >+ Format.sprintf "%.1f MiB" (v /. mib) >+ else if v > 1024. then >+ Format.sprintf "%.1f KiB" (v /. 1024.) >+ else >+ Format.sprintf "%.0f B" v >+ >+let statistics () = >+ let title = "Statistics" in >+ let t = GWindow.dialog ~title () in >+ let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in >+ t_dismiss#grab_default (); >+ let dismiss () = t#misc#hide () in >+ ignore (t_dismiss#connect#clicked ~callback:dismiss); >+ ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true)); >+ >+(* let emission = new stats 320 50 in >+ t#vbox#pack ~expand:false ~padding:4 (emission :> GObj.widget); >+ let reception = new stats 320 50 in >+ t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);*) >+ >+ let cols = new GTree.column_list in >+ let c_1 = cols#add Gobject.Data.string in >+ let c_client = cols#add Gobject.Data.string in >+ let c_server = cols#add Gobject.Data.string in >+ let c_total = cols#add Gobject.Data.string in >+ let lst = GTree.list_store cols in >+ let l = GTree.view ~model:lst ~enable_search:false ~packing:(t#vbox#add) () in >+ l#selection#set_mode `NONE; >+ ignore (l#append_column (GTree.view_column ~title:"" >+ ~renderer:(GTree.cell_renderer_text [], ["text", c_1]) ())); >+ ignore (l#append_column (GTree.view_column ~title:"Client" >+ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_client]) ())); >+ ignore (l#append_column (GTree.view_column ~title:"Server" >+ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_server]) ())); >+ ignore (l#append_column (GTree.view_column ~title:"Total" >+ ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_total]) ())); >+ let rate_row = lst#append () in >+ ignore (lst#set rate_row c_1 "Reception rate"); >+ let receive_row = lst#append () in >+ ignore (lst#set receive_row c_1 "Data received"); >+ let data_row = lst#append () in >+ ignore (lst#set data_row c_1 "File data written"); >+(* >+ ignore (t#event#connect#map ~callback:(fun _ -> >+ emission#activate true; >+ reception#activate true; >+ false)); >+ ignore (t#event#connect#unmap ~callback:(fun _ -> >+ emission#activate false; >+ reception#activate false; >+ false));*) >+ >+ let delay = 0.5 in >+ let a = 0.5 in >+ let b = 0.8 in >+ >+ let emittedBytes = ref 0. in >+ let emitRate = ref 0. in >+ let receivedBytes = ref 0. in >+ let receiveRate = ref 0. in >+ >+ let stopCounter = ref 0 in >+ >+ let updateTable () = >+ let row = rate_row in >+ lst#set ~row ~column:c_client (rate2str !receiveRate2); >+ lst#set ~row ~column:c_server (rate2str !emitRate2); >+ lst#set ~row ~column:c_total (rate2str (!receiveRate2 +. !emitRate2)); >+ let row = receive_row in >+ lst#set ~row ~column:c_client (kib2str !receivedBytes); >+ lst#set ~row ~column:c_server (kib2str !emittedBytes); >+ lst#set ~row ~column:c_total (kib2str (!receivedBytes +. !emittedBytes)); >+ let row = data_row in >+ lst#set ~row ~column:c_client (kib2str !clientWritten); >+ lst#set ~row ~column:c_server (kib2str !serverWritten); >+ lst#set ~row ~column:c_total (kib2str (!clientWritten +. !serverWritten)) >+ in >+ let timeout _ = >+ emitRate := >+ a *. !emitRate +. >+ (1. -. a) *. (!Remote.emittedBytes -. !emittedBytes) /. delay; >+ emitRate2 := >+ b *. !emitRate2 +. >+ (1. -. b) *. (!Remote.emittedBytes -. !emittedBytes) /. delay; >+(* emission#push !emitRate;*) >+ receiveRate := >+ a *. !receiveRate +. >+ (1. -. a) *. (!Remote.receivedBytes -. !receivedBytes) /. delay; >+ receiveRate2 := >+ b *. !receiveRate2 +. >+ (1. -. b) *. (!Remote.receivedBytes -. !receivedBytes) /. delay; >+(* reception#push !receiveRate;*) >+ emittedBytes := !Remote.emittedBytes; >+ receivedBytes := !Remote.receivedBytes; >+ if !stopCounter > 0 then decr stopCounter; >+ if !stopCounter = 0 then begin >+ emitRate2 := 0.; receiveRate2 := 0.; >+ end; >+ updateTable (); >+ !stopCounter <> 0 >+ in >+ let startStats () = >+ if !stopCounter = 0 then begin >+ emittedBytes := !Remote.emittedBytes; >+ receivedBytes := !Remote.receivedBytes; >+ stopCounter := -1; >+ ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.)) >+ ~callback:timeout) >+ end else >+ stopCounter := -1 >+ in >+ let stopStats () = stopCounter := 10 in >+ (t, startStats, stopStats) >+ >+(* ------ *) >+ >+let fatalError message = >+ let () = >+ try Trace.log (message ^ "\n") >+ with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *) >+ let title = "Fatal error" in >+ let t = >+ GWindow.dialog ~parent:(toplevelWindow ()) >+ ~border_width:6 ~modal:true ~resizable:false () in >+ t#vbox#set_spacing 12; >+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >+ ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG >+ ~yalign:0. ~packing:h1#pack ()); >+ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >+ ignore (GMisc.label >+ ~markup:(primaryText title ^ "\n\n" ^ >+ escapeMarkup (transcode message)) >+ ~line_wrap:true ~selectable:true ~yalign:0. ~packing:v1#add ()); >+ t#add_button_stock `QUIT `QUIT; >+ t#set_default_response `QUIT; >+ t#show(); ignore (t#run ()); t#destroy (); >+ exit 1 >+ >+(* ------ *) >+ >+let tryAgainOrQuit = fatalError >+ >+(* ------ *) >+ >+let getFirstRoot () = >+ let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection" >+ ~modal:true ~resizable:true () in >+ t#misc#grab_focus (); >+ >+ let hb = GPack.hbox >+ ~packing:(t#vbox#pack ~expand:false ~padding:15) () in >+ ignore(GMisc.label ~text:tryAgainMessage >+ ~justify:`LEFT >+ ~packing:(hb#pack ~expand:false ~padding:15) ()); >+ >+ let f1 = GPack.hbox ~spacing:4 >+ ~packing:(t#vbox#pack ~expand:true ~padding:4) () in >+ ignore (GMisc.label ~text:"Dir:" ~packing:(f1#pack ~expand:false) ()); >+ let fileE = GEdit.entry ~packing:f1#add () in >+ fileE#misc#grab_focus (); >+ let b = GFile.chooser_button ~action:`SELECT_FOLDER >+ ~title:"Select a local directory" >+ ~packing:(f1#pack ~expand:false) () in >+ ignore (b#connect#selection_changed ~callback:(fun () -> >+ if not fileE#is_focus then >+ fileE#set_text (match b#filename with None -> "" | Some s -> s))); >+ ignore (fileE#connect#changed ~callback:(fun () -> >+ if fileE#is_focus then ignore (b#set_filename fileE#text))); >+ >+ let f3 = t#action_area in >+ let result = ref None in >+ let contCommand() = >+ result := Some(fileE#text); >+ t#destroy () in >+ let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in >+ ignore (quitButton#connect#clicked >+ ~callback:(fun () -> result := None; t#destroy())); >+ let contButton = GButton.button ~stock:`OK ~packing:f3#add () in >+ ignore (contButton#connect#clicked ~callback:contCommand); >+ ignore (fileE#connect#activate ~callback:contCommand); >+ contButton#grab_default (); >+ t#show (); >+ ignore (t#connect#destroy ~callback:GMain.Main.quit); >+ GMain.Main.main (); >+ match !result with None -> None >+ | Some file -> >+ Some(Clroot.clroot2string(Clroot.ConnectLocal(Some file))) >+ >+(* ------ *) >+ >+let getSecondRoot () = >+ let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection" >+ ~modal:true ~resizable:true () in >+ t#misc#grab_focus (); >+ >+ let message = "Please enter the second directory you want to synchronize." in >+ >+ let vb = t#vbox in >+ let hb = GPack.hbox ~packing:(vb#pack ~expand:false ~padding:15) () in >+ ignore(GMisc.label ~text:message >+ ~justify:`LEFT >+ ~packing:(hb#pack ~expand:false ~padding:15) ()); >+ let helpB = GButton.button ~stock:`HELP ~packing:hb#add () in >+ ignore (helpB#connect#clicked >+ ~callback:(fun () -> okBox ~parent:t ~title:"Picking roots" ~typ:`INFO >+ ~message:helpmessage)); >+ >+ let result = ref None in >+ >+ let f = GPack.vbox ~packing:(vb#pack ~expand:false) () in >+ >+ let f1 = GPack.hbox ~spacing:4 ~packing:f#add () in >+ ignore (GMisc.label ~text:"Directory:" ~packing:(f1#pack ~expand:false) ()); >+ let fileE = GEdit.entry ~packing:f1#add () in >+ fileE#misc#grab_focus (); >+ let b = GFile.chooser_button ~action:`SELECT_FOLDER >+ ~title:"Select a local directory" >+ ~packing:(f1#pack ~expand:false) () in >+ ignore (b#connect#selection_changed ~callback:(fun () -> >+ if not fileE#is_focus then >+ fileE#set_text (match b#filename with None -> "" | Some s -> s))); >+ ignore (fileE#connect#changed ~callback:(fun () -> >+ if fileE#is_focus then ignore (b#set_filename fileE#text))); >+ >+ let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in >+ let localB = GButton.radio_button ~packing:(f0#pack ~expand:false) >+ ~label:"Local" () in >+ let sshB = GButton.radio_button ~group:localB#group >+ ~packing:(f0#pack ~expand:false) >+ ~label:"SSH" () in >+ let rshB = GButton.radio_button ~group:localB#group >+ ~packing:(f0#pack ~expand:false) ~label:"RSH" () in >+ let socketB = GButton.radio_button ~group:sshB#group >+ ~packing:(f0#pack ~expand:false) ~label:"Socket" () in >+ >+ let f2 = GPack.hbox ~spacing:4 ~packing:f#add () in >+ ignore (GMisc.label ~text:"Host:" ~packing:(f2#pack ~expand:false) ()); >+ let hostE = GEdit.entry ~packing:f2#add () in >+ >+ ignore (GMisc.label ~text:"(Optional) User:" >+ ~packing:(f2#pack ~expand:false) ()); >+ let userE = GEdit.entry ~packing:f2#add () in >+ >+ ignore (GMisc.label ~text:"Port:" >+ ~packing:(f2#pack ~expand:false) ()); >+ let portE = GEdit.entry ~packing:f2#add () in >+ >+ let varLocalRemote = ref (`Local : [`Local|`SSH|`RSH|`SOCKET]) in >+ let localState() = >+ varLocalRemote := `Local; >+ hostE#misc#set_sensitive false; >+ userE#misc#set_sensitive false; >+ portE#misc#set_sensitive false; >+ b#misc#set_sensitive true in >+ let remoteState() = >+ hostE#misc#set_sensitive true; >+ b#misc#set_sensitive false; >+ match !varLocalRemote with >+ `SOCKET -> >+ (portE#misc#set_sensitive true; userE#misc#set_sensitive false) >+ | _ -> >+ (portE#misc#set_sensitive false; userE#misc#set_sensitive true) in >+ let protoState x = >+ varLocalRemote := x; >+ remoteState() in >+ ignore (localB#connect#clicked ~callback:localState); >+ ignore (sshB#connect#clicked ~callback:(fun () -> protoState(`SSH))); >+ ignore (rshB#connect#clicked ~callback:(fun () -> protoState(`RSH))); >+ ignore (socketB#connect#clicked ~callback:(fun () -> protoState(`SOCKET))); >+ localState(); >+ let getRoot() = >+ let file = fileE#text in >+ let user = userE#text in >+ let host = hostE#text in >+ let port = portE#text in >+ match !varLocalRemote with >+ `Local -> >+ Clroot.clroot2string(Clroot.ConnectLocal(Some file)) >+ | `SSH | `RSH -> >+ Clroot.clroot2string( >+ Clroot.ConnectByShell((if !varLocalRemote=`SSH then "ssh" else "rsh"), >+ host, >+ (if user="" then None else Some user), >+ (if port="" then None else Some port), >+ Some file)) >+ | `SOCKET -> >+ Clroot.clroot2string( >+ (* FIX: report an error if the port entry is not well formed *) >+ Clroot.ConnectBySocket(host, >+ portE#text, >+ Some file)) in >+ let contCommand() = >+ try >+ let root = getRoot() in >+ result := Some root; >+ t#destroy () >+ with Failure _ -> >+ if portE#text="" then >+ okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Please enter a port" >+ else okBox ~parent:t ~title:"Error" ~typ:`ERROR >+ ~message:"The port you specify must be an integer" >+ | _ -> >+ okBox ~parent:t ~title:"Error" ~typ:`ERROR >+ ~message:"Something's wrong with the values you entered, try again" in >+ let f3 = t#action_area in >+ let quitButton = >+ GButton.button ~stock:`QUIT ~packing:f3#add () in >+ ignore (quitButton#connect#clicked ~callback:safeExit); >+ let contButton = >+ GButton.button ~stock:`OK ~packing:f3#add () in >+ ignore (contButton#connect#clicked ~callback:contCommand); >+ contButton#grab_default (); >+ ignore (fileE#connect#activate ~callback:contCommand); >+ >+ t#show (); >+ ignore (t#connect#destroy ~callback:GMain.Main.quit); >+ GMain.Main.main (); >+ !result >+ >+(* ------ *) >+ >+let getPassword rootName msg = >+ let t = >+ GWindow.dialog ~parent:(toplevelWindow ()) >+ ~title:"Unison: SSH connection" ~position:`CENTER >+ ~modal:true ~resizable:false ~border_width:6 () in >+ t#misc#grab_focus (); >+ >+ t#vbox#set_spacing 12; >+ >+ let header = >+ primaryText >+ (Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in >+ >+ let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in >+ ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG >+ ~yalign:0. ~packing:h1#pack ()); >+ let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in >+ ignore(GMisc.label ~markup:(header ^ "\n\n" ^ >+ escapeMarkup (Unicode.protect msg)) >+ ~selectable:true ~yalign:0. ~packing:v1#pack ()); >+ >+ let passwordE = GEdit.entry ~packing:v1#pack ~visibility:false () in >+ passwordE#misc#grab_focus (); >+ >+ t#add_button_stock `QUIT `QUIT; >+ t#add_button_stock `OK `OK; >+ t#set_default_response `OK; >+ ignore (passwordE#connect#activate ~callback:(fun _ -> t#response `OK)); >+ >+ t#show(); >+ let res = t#run () in >+ let pwd = passwordE#text in >+ t#destroy (); >+ gtk_sync true; >+ begin match res with >+ `DELETE_EVENT | `QUIT -> safeExit (); "" >+ | `OK -> pwd >+ end >+ >+let termInteract = Some getPassword >+ >+(* ------ *) >+ >+module React = struct >+ type 'a t = { mutable state : 'a; mutable observers : ('a -> unit) list } >+ >+ let make v = >+ let res = { state = v; observers = [] } in >+ let update v = >+ if res.state <> v then begin >+ res.state <- v; List.iter (fun f -> f v) res.observers >+ end >+ in >+ (res, update) >+ >+ let const v = fst (make v) >+ >+ let add_observer x f = x.observers <- f :: x.observers >+ >+ let state x = x.state >+ >+ let lift f x = >+ let (res, update) = make (f (state x)) in >+ add_observer x (fun v -> update (f v)); >+ res >+ >+ let lift2 f x y = >+ let (res, update) = make (f (state x) (state y)) in >+ add_observer x (fun v -> update (f v (state y))); >+ add_observer y (fun v -> update (f (state x) v)); >+ res >+ >+ let lift3 f x y z = >+ let (res, update) = make (f (state x) (state y) (state z)) in >+ add_observer x (fun v -> update (f v (state y) (state z))); >+ add_observer y (fun v -> update (f (state x) v (state z))); >+ add_observer z (fun v -> update (f (state x) (state y) v)); >+ res >+ >+ let iter f x = f (state x); add_observer x f >+ >+ type 'a event = { mutable ev_observers : ('a -> unit) list } >+ >+ let make_event () = >+ let res = { ev_observers = [] } in >+ let trigger v = List.iter (fun f -> f v) res.ev_observers in >+ (res, trigger) >+ >+ let add_ev_observer x f = x.ev_observers <- f :: x.ev_observers >+ >+ let hold v e = >+ let (res, update) = make v in >+ add_ev_observer e update; >+ res >+ >+ let iter_ev f e = add_ev_observer e f >+ >+ let lift_ev f e = >+ let (res, trigger) = make_event () in >+ add_ev_observer e (fun x -> trigger (f x)); >+ res >+ >+ module Ops = struct >+ let (>>) x f = lift f x >+ let (>|) x f = iter f x >+ >+ let (>>>) x f = lift_ev f x >+ let (>>|) x f = iter_ev f x >+ end >+end >+ >+module GtkReact = struct >+ let entry (e : #GEdit.entry) = >+ let (res, update) = React.make e#text in >+ ignore (e#connect#changed ~callback:(fun () -> update (e#text))); >+ res >+ >+ let text_combo ((c, _) : _ GEdit.text_combo) = >+ let (res, update) = React.make c#active in >+ ignore (c#connect#changed ~callback:(fun () -> update (c#active))); >+ res >+ >+ let toggle_button (b : #GButton.toggle_button) = >+ let (res, update) = React.make b#active in >+ ignore (b#connect#toggled ~callback:(fun () -> update (b#active))); >+ res >+ >+ let file_chooser (c : #GFile.chooser) = >+ let (res, update) = React.make c#filename in >+ ignore (c#connect#selection_changed >+ ~callback:(fun () -> update (c#filename))); >+ res >+ >+ let current_tree_view_selection (t : #GTree.view) = >+ let m =t#model in >+ Safelist.map (fun p -> m#get_row_reference p) t#selection#get_selected_rows >+ >+ let tree_view_selection_changed t = >+ let (res, trigger) = React.make_event () in >+ ignore (t#selection#connect#changed >+ ~callback:(fun () -> trigger (current_tree_view_selection t))); >+ res >+ >+ let tree_view_selection t = >+ React.hold (current_tree_view_selection t) (tree_view_selection_changed t) >+ >+ let label (l : #GMisc.label) x = React.iter (fun v -> l#set_text v) x >+ >+ let label_underlined (l : #GMisc.label) x = >+ React.iter (fun v -> l#set_text v; l#set_use_underline true) x >+ >+ let label_markup (l : #GMisc.label) x = >+ React.iter (fun v -> l#set_text v; l#set_use_markup true) x >+ >+ let show w x = >+ React.iter (fun b -> if b then w#misc#show () else w#misc#hide ()) x >+ let set_sensitive w x = React.iter (fun b -> w#misc#set_sensitive b) x >+end >+ >+open React.Ops >+ >+(* ------ *) >+ >+(* Resize an object (typically, a label with line wrapping) so that it >+ use all its available space *) >+let adjustSize (w : #GObj.widget) = >+ let notYet = ref true in >+ ignore >+ (w#misc#connect#size_allocate ~callback:(fun r -> >+ if !notYet then begin >+ notYet := false; >+ (* JV: I have no idea where the 12 comes from. Without it, >+ a window resize may happen. *) >+ w#misc#set_size_request ~width:(max 10 (r.Gtk.width - 12)) () >+ end)) >+ >+let createProfile parent = >+ let assistant = GAssistant.assistant ~modal:true () in >+ assistant#set_transient_for parent#as_window; >+ assistant#set_modal true; >+ assistant#set_title "Profile Creation"; >+ >+ let nonEmpty s = s <> "" in >+(* >+ let integerRe = >+ Str.regexp "\\([+-]?[0-9]+\\|0o[0-7]+\\|0x[0-9a-zA-Z]+\\)" in >+*) >+ let integerRe = Str.regexp "[0-9]+" in >+ let isInteger s = >+ Str.string_match integerRe s 0 && Str.matched_string s = s in >+ >+ (* Introduction *) >+ let intro = >+ GMisc.label >+ ~xpad:12 ~ypad:12 >+ ~text:"Welcome to the Unison Profile Creation Assistant.\n\n\ >+ Click \"Next\" to begin." >+ () in >+ ignore >+ (assistant#append_page >+ ~title:"Profile Creation" >+ ~page_type:`INTRO >+ ~complete:true >+ intro#as_widget); >+ >+ (* Profile name and description *) >+ let description = GPack.vbox ~border_width:12 ~spacing:6 () in >+ adjustSize >+ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >+ ~text:"Please enter the name of the profile and \ >+ possibly a short description." >+ ~packing:(description#pack ~expand:false) ()); >+ let tbl = >+ let al = GBin.alignment ~packing:(description#pack ~expand:false) () in >+ al#set_left_padding 12; >+ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 >+ ~packing:(al#add) () in >+ let nameEntry = >+ GEdit.entry ~activates_default:true >+ ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in >+ let name = GtkReact.entry nameEntry in >+ ignore (GMisc.label ~text:"Profile _name:" ~xalign:0. >+ ~use_underline:true ~mnemonic_widget:nameEntry >+ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >+ let labelEntry = >+ GEdit.entry ~activates_default:true >+ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in >+ let label = GtkReact.entry labelEntry in >+ ignore (GMisc.label ~text:"_Description:" ~xalign:0. >+ ~use_underline:true ~mnemonic_widget:labelEntry >+ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); >+ let existingProfileLabel = >+ GMisc.label ~xalign:1. ~packing:(description#pack ~expand:false) () >+ in >+ adjustSize existingProfileLabel; >+ GtkReact.label_markup existingProfileLabel >+ (name >> fun s -> Format.sprintf " <i>Profile %s already exists.</i>" >+ (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:"<b>Configuration</b>" ~xalign:0. >+ ~packing:(vb#pack ~expand:false) ()); >+ let al = GBin.alignment ~packing:(vb#add) () in >+ al#set_left_padding 12; >+ let vb = GPack.vbox ~spacing:6 ~packing:(al#add) () in >+ let requirementLabel = >+ GMisc.label ~xalign:0. ~line_wrap:true >+ ~packing:(vb#pack ~expand:false) () >+ in >+ adjustSize requirementLabel; >+ GtkReact.label requirementLabel >+ (kind >> fun k -> >+ match k with >+ `Local -> >+ "" >+ | `SSH -> >+ "There must be an SSH client installed on this machine, \ >+ and Unison and an SSH server installed on the remote machine." >+ | `RSH -> >+ "There must be an RSH client installed on this machine, \ >+ and Unison and an RSH server installed on the remote machine." >+ | `SOCKET -> >+ "There must be a Unison server running on the remote machine, \ >+ listening on the port that you specify here. \ >+ (Use \"Unison -socket xxx\" on the remote machine to start \ >+ the Unison server.)"); >+ let connDescLabel = >+ GMisc.label ~xalign:0. ~line_wrap:true >+ ~packing:(vb#pack ~expand:false) () >+ in >+ adjustSize connDescLabel; >+ GtkReact.label connDescLabel >+ (kind >> fun k -> >+ match k with >+ `Local -> "" >+ | `SSH -> "Please enter the host to connect to and a user name, \ >+ if different from your user name on this machine." >+ | `RSH -> "Please enter the host to connect to and a user name, \ >+ if different from your user name on this machine." >+ | `SOCKET -> "Please enter the host and port to connect to."); >+ let tbl = >+ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >+ al#set_left_padding 12; >+ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 >+ ~packing:(al#add) () in >+ let hostEntry = >+ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in >+ let host = GtkReact.entry hostEntry in >+ ignore (GMisc.label ~text:"_Host:" ~xalign:0. >+ ~use_underline:true ~mnemonic_widget:hostEntry >+ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >+ let userEntry = >+ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () >+ in >+ GtkReact.show userEntry (isSocket >> not); >+ let user = GtkReact.entry userEntry in >+ GtkReact.show >+ (GMisc.label ~text:"_User:" ~xalign:0. ~yalign:0. >+ ~use_underline:true ~mnemonic_widget:userEntry >+ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()) >+ (isSocket >> not); >+ let portEntry = >+ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () >+ in >+ GtkReact.show portEntry isSocket; >+ let port = GtkReact.entry portEntry in >+ GtkReact.show >+ (GMisc.label ~text:"_Port:" ~xalign:0. ~yalign:0. >+ ~use_underline:true ~mnemonic_widget:portEntry >+ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()) >+ isSocket; >+ let compressLabel = >+ GMisc.label ~xalign:0. ~line_wrap:true >+ ~text:"Data compression can greatly improve performance \ >+ on slow connections. However, it may slow down \ >+ things on (fast) local networks." >+ ~packing:(vb#pack ~expand:false) () >+ in >+ adjustSize compressLabel; >+ GtkReact.show compressLabel isSSH; >+ let compressButton = >+ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >+ al#set_left_padding 12; >+ (GButton.check_button ~label:"Enable _compression" ~use_mnemonic:true >+ ~active:true ~packing:(al#add) ()) >+ in >+ GtkReact.show compressButton isSSH; >+ let compress = GtkReact.toggle_button compressButton in >+(*XXX Disabled for now... *) >+(* >+ adjustSize >+ (GMisc.label ~xalign:0. ~line_wrap:true >+ ~text:"If this is possible, it is recommended that Unison \ >+ attempts to connect immediately to the remote machine, \ >+ so that it can perform some auto-detections." >+ ~packing:(vb#pack ~expand:false) ()); >+ let connectImmediately = >+ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >+ al#set_left_padding 12; >+ GtkReact.toggle_button >+ (GButton.check_button ~label:"Connect _immediately" ~use_mnemonic:true >+ ~active:true ~packing:(al#add) ()) >+ in >+ let connectImmediately = >+ React.lift2 (&&) connectImmediately (isLocal >> not) in >+*) >+ let pageComplete = >+ React.lift2 (||) isLocal >+ (React.lift2 (&&) (host >> nonEmpty) >+ (React.lift2 (||) (isSocket >> not) (port >> isInteger))) >+ in >+ ignore >+ (assistant#append_page >+ ~title:"Connection Setup" >+ ~page_type:`CONTENT >+ connection#as_widget); >+ pageComplete >| setPageComplete connection; >+ >+ (* Connection to server *) >+(*XXX Disabled for now... Fill in this page >+ let connectionInProgress = GMisc.label ~text:"..." () in >+ let p = >+ assistant#append_page >+ ~title:"Connecting to Server..." >+ ~page_type:`PROGRESS >+ connectionInProgress#as_widget >+ in >+ ignore >+ (assistant#connect#prepare (fun () -> >+ if assistant#current_page = p then begin >+ if React.state connectImmediately then begin >+ (* XXXX start connection... *) >+ assistant#set_page_complete connectionInProgress#as_widget true >+ end else >+ assistant#set_current_page (p + 1) >+ end)); >+*) >+ >+ (* Directory selection *) >+ let directorySelection = GPack.vbox ~border_width:12 ~spacing:6 () in >+ adjustSize >+ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >+ ~text:"Please select the two directories that you want to synchronize." >+ ~packing:(directorySelection#pack ~expand:false) ()); >+ let secondDirLabel1 = >+ GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >+ ~text:"The second directory is relative to your home \ >+ directory on the remote machine." >+ ~packing:(directorySelection#pack ~expand:false) () >+ in >+ adjustSize secondDirLabel1; >+ GtkReact.show secondDirLabel1 ((React.lift2 (||) isLocal isSocket) >> not); >+ let secondDirLabel2 = >+ GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >+ ~text:"The second directory is relative to \ >+ the working directory of the Unison server \ >+ running on the remote machine." >+ ~packing:(directorySelection#pack ~expand:false) () >+ in >+ adjustSize secondDirLabel2; >+ GtkReact.show secondDirLabel2 isSocket; >+ let tbl = >+ let al = >+ GBin.alignment ~packing:(directorySelection#pack ~expand:false) () in >+ al#set_left_padding 12; >+ GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 >+ ~packing:(al#add) () in >+(*XXX Should focus on this button when becomes visible... *) >+ let firstDirButton = >+ GFile.chooser_button ~action:`SELECT_FOLDER ~title:"First Directory" >+ ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () >+ in >+ isLocal >| (fun b -> firstDirButton#set_title >+ (if b then "First Directory" else "Local Directory")); >+ GtkReact.label_underlined >+ (GMisc.label ~xalign:0. >+ ~mnemonic_widget:firstDirButton >+ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()) >+ (isLocal >> fun b -> >+ if b then "_First directory:" else "_Local directory:"); >+ let noneToEmpty o = match o with None -> "" | Some s -> s in >+ let firstDir = GtkReact.file_chooser firstDirButton >> noneToEmpty in >+ let secondDirButton = >+ GFile.chooser_button ~action:`SELECT_FOLDER ~title:"Second Directory" >+ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in >+ let secondDirLabel = >+ GMisc.label ~xalign:0. >+ ~text:"Se_cond directory:" >+ ~use_underline:true ~mnemonic_widget:secondDirButton >+ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () in >+ GtkReact.show secondDirButton isLocal; >+ GtkReact.show secondDirLabel isLocal; >+ let remoteDirEdit = >+ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () >+ in >+ let remoteDirLabel = >+ GMisc.label ~xalign:0. >+ ~text:"_Remote directory:" >+ ~use_underline:true ~mnemonic_widget:remoteDirEdit >+ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () >+ in >+ GtkReact.show remoteDirEdit (isLocal >> not); >+ GtkReact.show remoteDirLabel (isLocal >> not); >+ let secondDir = >+ React.lift3 (fun b l r -> if b then l else r) isLocal >+ (GtkReact.file_chooser secondDirButton >> noneToEmpty) >+ (GtkReact.entry remoteDirEdit) >+ in >+ ignore >+ (assistant#append_page >+ ~title:"Directory Selection" >+ ~page_type:`CONTENT >+ directorySelection#as_widget); >+ React.lift2 (||) (isLocal >> not) (React.lift2 (<>) firstDir secondDir) >+ >| setPageComplete directorySelection; >+ >+ (* Specific options *) >+ let options = GPack.vbox ~border_width:18 ~spacing:12 () in >+ (* Do we need to set specific options for FAT partitions? >+ If under Windows, then all the options are set properly, except for >+ ignoreinodenumbers in case one replica is on a FAT partition on a >+ remote non-Windows machine. As this is unlikely, we do not >+ handle this case. *) >+ let fat = >+ if Util.osType = `Win32 then >+ React.const false >+ else begin >+ let vb = >+ GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in >+ let fatLabel = >+ GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >+ ~text:"Select the following option if one of your \ >+ directory is on a FAT partition. This is typically \ >+ the case for a USB stick." >+ ~packing:(vb#pack ~expand:false) () >+ in >+ adjustSize fatLabel; >+ let fatButton = >+ let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in >+ al#set_left_padding 12; >+ (GButton.check_button >+ ~label:"Synchronization involving a _FAT partition" >+ ~use_mnemonic:true ~active:false ~packing:(al#add) ()) >+ in >+ GtkReact.toggle_button fatButton >+ end >+ in >+ (* Fastcheck is safe except on FAT partitions and on Windows when >+ not in Unicode mode where there is a very slight chance of >+ missing an update when a file is moved onto another with the same >+ modification time. Nowadays, FAT is rarely used on working >+ partitions. In most cases, we should be in Unicode mode. >+ Thus, it seems sensible to always enable fastcheck. *) >+(* >+ let fastcheck = isLocal >> not >> (fun b -> b || Util.osType = `Win32) in >+*) >+ (* Unicode mode can be problematic when the source machine is under >+ Windows and the remote machine is not, as Unison may have already >+ been used using the legacy Latin 1 encoding. Cygwin also did not >+ handle Unicode before version 1.7. *) >+ let vb = GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in >+ let askUnicode = React.const false in >+(* isLocal >> not >> fun b -> (b || Util.isCygwin) && Util.osType = `Win32 in*) >+ GtkReact.show vb askUnicode; >+ adjustSize >+ (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT >+ ~text:"When synchronizing in case insensitive mode, \ >+ Unison has to make some assumptions regarding \ >+ filename encoding. If ensure, use Unicode." >+ ~packing:(vb#pack ~expand:false) ()); >+ let vb = >+ let al = GBin.alignment >+ ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in >+ al#set_left_padding 12; >+ GPack.vbox ~spacing:0 ~packing:(al#add) () >+ in >+ ignore >+ (GMisc.label ~xalign:0. ~text:"Filename encoding:" >+ ~packing:(vb#pack ~expand:false) ()); >+ let hb = >+ let al = GBin.alignment >+ ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in >+ al#set_left_padding 12; >+ GPack.button_box `VERTICAL ~layout:`START >+ ~spacing:0 ~packing:(al#add) () >+ in >+ let unicodeButton = >+ GButton.radio_button ~label:"_Unicode" ~use_mnemonic:true ~active:true >+ ~packing:(hb#add) () >+ in >+ ignore >+ (GButton.radio_button ~label:"_Latin 1" ~use_mnemonic:true >+ ~group:unicodeButton#group ~packing:(hb#add) ()); >+(* >+ let unicode = >+ React.lift2 (||) (askUnicode >> not) (GtkReact.toggle_button unicodeButton) >+ in >+*) >+ let p = >+ assistant#append_page >+ ~title:"Specific Options" ~complete:true >+ ~page_type:`CONTENT >+ options#as_widget >+ in >+ ignore >+ (assistant#connect#prepare ~callback:(fun () -> >+ if assistant#current_page = p && >+ not (Util.osType <> `Win32 || React.state askUnicode) >+ then >+ assistant#set_current_page (p + 1))); >+ >+ let conclusion = >+ GMisc.label >+ ~xpad:12 ~ypad:12 >+ ~text:"You have now finished filling in the profile.\n\n\ >+ Click \"Apply\" to create it." >+ () in >+ ignore >+ (assistant#append_page >+ ~title:"Done" ~complete:true >+ ~page_type:`CONFIRM >+ conclusion#as_widget); >+ >+ let profileName = ref None in >+ let saveProfile () = >+ let filename = Prefs.profilePathname (React.state name) in >+ begin try >+ let ch = >+ System.open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename >+ in >+ Printf.fprintf ch "# Unison preferences\n"; >+ let label = React.state label in >+ if label <> "" then Printf.fprintf ch "label = %s\n" label; >+ Printf.fprintf ch "root = %s\n" (React.state firstDir); >+ let secondDir = React.state secondDir in >+ let host = React.state host in >+ let user = match React.state user with "" -> None | u -> Some u in >+ let secondRoot = >+ match React.state kind with >+ `Local -> Clroot.ConnectLocal (Some secondDir) >+ | `SSH -> Clroot.ConnectByShell >+ ("ssh", host, user, None, Some secondDir) >+ | `RSH -> Clroot.ConnectByShell >+ ("rsh", host, user, None, Some secondDir) >+ | `SOCKET -> Clroot.ConnectBySocket >+ (host, React.state port, Some secondDir) >+ in >+ Printf.fprintf ch "root = %s\n" (Clroot.clroot2string secondRoot); >+ if React.state compress && React.state kind = `SSH then >+ Printf.fprintf ch "sshargs = -C\n"; >+(* >+ if React.state fastcheck then >+ Printf.fprintf ch "fastcheck = true\n"; >+ if React.state unicode then >+ Printf.fprintf ch "unicode = true\n"; >+*) >+ if React.state fat then Printf.fprintf ch "fat = true\n"; >+ close_out ch; >+ profileName := Some (React.state name) >+ with Sys_error _ as e -> >+ okBox ~parent:assistant ~typ:`ERROR ~title:"Could not save profile" >+ ~message:(Uicommon.exn2string e) >+ end; >+ assistant#destroy (); >+ in >+ ignore (assistant#connect#close ~callback:saveProfile); >+ ignore (assistant#connect#destroy ~callback:GMain.Main.quit); >+ ignore (assistant#connect#cancel ~callback:assistant#destroy); >+ assistant#show (); >+ GMain.Main.main (); >+ !profileName >+ >+(* ------ *) >+ >+let nameOfType t = >+ match t with >+ `BOOL -> "boolean" >+ | `BOOLDEF -> "boolean" >+ | `INT -> "integer" >+ | `STRING -> "text" >+ | `STRING_LIST -> "text list" >+ | `CUSTOM -> "custom" >+ | `UNKNOWN -> "unknown" >+ >+let defaultValue t = >+ match t with >+ `BOOL -> ["true"] >+ | `BOOLDEF -> ["true"] >+ | `INT -> ["0"] >+ | `STRING -> [""] >+ | `STRING_LIST -> [] >+ | `CUSTOM -> [] >+ | `UNKNOWN -> [] >+ >+let editPreference parent nm ty vl = >+ let t = >+ GWindow.dialog ~parent ~border_width:12 >+ ~title:"Edit the Preference" >+ ~modal:true () in >+ let vb = t#vbox in >+ vb#set_spacing 6; >+ >+ let isList = >+ match ty with >+ `STRING_LIST | `CUSTOM | `UNKNOWN -> true >+ | _ -> false >+ in >+ let columns = if isList then 5 else 4 in >+ let rows = if isList then 3 else 2 in >+ let tbl = >+ GPack.table ~rows ~columns ~col_spacings:12 ~row_spacings:6 >+ ~packing:(vb#pack ~expand:false) () in >+ ignore (GMisc.label ~text:"Preference:" ~xalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >+ ignore (GMisc.label ~text:"Description:" ~xalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); >+ ignore (GMisc.label ~text:"Type:" ~xalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:2 ~expand:`NONE) ()); >+ ignore (GMisc.label ~text:(Unicode.protect nm) ~xalign:0. ~selectable:true () >+ ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)); >+ let (doc, _, _) = Prefs.documentation nm in >+ ignore (GMisc.label ~text:doc ~xalign:0. ~selectable:true () >+ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X)); >+ ignore (GMisc.label ~text:(nameOfType ty) ~xalign:0. ~selectable:true () >+ ~packing:(tbl#attach ~left:1 ~top:2 ~expand:`X)); >+ let newValue = >+ if isList then begin >+ let valueLabel = >+ GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. ~yalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) () >+ in >+ let cols = new GTree.column_list in >+ let c_value = cols#add Gobject.Data.string in >+ let c_ml = cols#add Gobject.Data.caml in >+ let lst_store = GTree.list_store cols in >+ let lst = >+ let sw = >+ GBin.scrolled_window ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) >+ ~shadow_type:`IN ~height:200 ~width:400 >+ ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in >+ GTree.view ~model:lst_store ~headers_visible:false >+ ~reorderable:true ~packing:sw#add () in >+ valueLabel#set_mnemonic_widget (Some (lst :> GObj.widget)); >+ let column = >+ GTree.view_column >+ ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) () >+ in >+ ignore (lst#append_column column); >+ let vb = >+ GPack.button_box >+ `VERTICAL ~layout:`START ~spacing:6 >+ ~packing:(tbl#attach ~left:2 ~top:3 ~expand:`NONE) () >+ in >+ let selection = GtkReact.tree_view_selection lst in >+ let hasSel = selection >> fun l -> l <> [] in >+ let addB = >+ GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in >+ let removeB = >+ GButton.button ~stock:`REMOVE ~packing:(vb#pack ~expand:false) () in >+ let editB = >+ GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in >+ let upB = >+ GButton.button ~stock:`GO_UP ~packing:(vb#pack ~expand:false) () in >+ let downB = >+ GButton.button ~stock:`GO_DOWN ~packing:(vb#pack ~expand:false) () in >+ List.iter (fun b -> b#set_xalign 0.) [addB; removeB; editB; upB; downB]; >+ GtkReact.set_sensitive removeB hasSel; >+ let editLabel = >+ GMisc.label ~text:"Edited _item:" >+ ~use_underline:true ~xalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:4 ~expand:`NONE) () >+ in >+ let editEntry = >+ GEdit.entry ~packing:(tbl#attach ~left:1 ~top:4 ~expand:`X) () in >+ editLabel#set_mnemonic_widget (Some (editEntry :> GObj.widget)); >+ let edit = GtkReact.entry editEntry in >+ let edited = >+ React.lift2 >+ (fun l txt -> >+ match l with >+ [rf] -> lst_store#get ~row:rf#iter ~column:c_ml <> txt >+ | _ -> false) >+ selection edit >+ in >+ GtkReact.set_sensitive editB edited; >+ let selectionChange = GtkReact.tree_view_selection_changed lst in >+ selectionChange >>| (fun s -> >+ match s with >+ [rf] -> editEntry#set_text >+ (lst_store#get ~row:rf#iter ~column:c_value) >+ | _ -> ()); >+ let add () = >+ let txt = editEntry#text in >+ let row = lst_store#append () in >+ lst_store#set ~row ~column:c_value txt; >+ lst_store#set ~row ~column:c_ml txt; >+ lst#selection#select_iter row; >+ lst#scroll_to_cell (lst_store#get_path row) column >+ in >+ ignore (addB#connect#clicked ~callback:add); >+ ignore (editEntry#connect#activate ~callback:add); >+ let remove () = >+ match React.state selection with >+ [rf] -> let i = rf#iter in >+ if lst_store#iter_next i then >+ lst#selection#select_iter i >+ else begin >+ let p = rf#path in >+ if GTree.Path.prev p then >+ lst#selection#select_path p >+ end; >+ ignore (lst_store#remove rf#iter) >+ | _ -> () >+ in >+ ignore (removeB#connect#clicked ~callback:remove); >+ let edit () = >+ match React.state selection with >+ [rf] -> let row = rf#iter in >+ let txt = editEntry#text in >+ lst_store#set ~row ~column:c_value txt; >+ lst_store#set ~row ~column:c_ml txt >+ | _ -> () >+ in >+ ignore (editB#connect#clicked ~callback:edit); >+ let updateUpDown l = >+ let (upS, downS) = >+ match l with >+ [rf] -> (GTree.Path.prev rf#path, lst_store#iter_next rf#iter) >+ | _ -> (false, false) >+ in >+ upB#misc#set_sensitive upS; >+ downB#misc#set_sensitive downS >+ in >+ selectionChange >>| updateUpDown; >+ ignore (lst_store#connect#after#row_deleted >+ ~callback:(fun _ -> updateUpDown (React.state selection))); >+ let go_up () = >+ match React.state selection with >+ [rf] -> let p = rf#path in >+ if GTree.Path.prev p then begin >+ let i = rf#iter in >+ let i' = lst_store#get_iter p in >+ ignore (lst_store#swap i i'); >+ lst#scroll_to_cell (lst_store#get_path i) column >+ end; >+ updateUpDown (React.state selection) >+ | _ -> () >+ in >+ ignore (upB#connect#clicked ~callback:go_up); >+ let go_down () = >+ match React.state selection with >+ [rf] -> let i = rf#iter in >+ if lst_store#iter_next i then begin >+ let i' = rf#iter in >+ ignore (lst_store#swap i i'); >+ lst#scroll_to_cell (lst_store#get_path i') column >+ end; >+ updateUpDown (React.state selection) >+ | _ -> () >+ in >+ ignore (downB#connect#clicked ~callback:go_down); >+ List.iter >+ (fun v -> >+ let row = lst_store#append () in >+ lst_store#set ~row ~column:c_value (Unicode.protect v); >+ lst_store#set ~row ~column:c_ml v) >+ vl; >+ (fun () -> >+ let l = ref [] in >+ lst_store#foreach >+ (fun _ row -> l := lst_store#get ~row ~column:c_ml :: !l; false); >+ List.rev !l) >+ end else begin >+ let v = List.hd vl in >+ begin match ty with >+ `BOOL | `BOOLDEF -> >+ let hb = >+ GPack.button_box `HORIZONTAL ~layout:`START >+ ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) () >+ in >+ let isTrue = v = "true" || v = "yes" in >+ let trueB = >+ GButton.radio_button ~label:"_True" ~use_mnemonic:true >+ ~active:isTrue ~packing:(hb#add) () >+ in >+ ignore >+ (GButton.radio_button ~label:"_False" ~use_mnemonic:true >+ ~group:trueB#group ~active:(not isTrue) ~packing:(hb#add) ()); >+ ignore >+ (GMisc.label ~text:"Value:" ~xalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()); >+ (fun () -> [if trueB#active then "true" else "false"]) >+ | `INT | `STRING -> >+ let valueEntry = >+ GEdit.entry ~text:v ~width_chars: 40 >+ ~activates_default:true >+ ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) () >+ in >+ ignore >+ (GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. >+ ~mnemonic_widget:valueEntry >+ ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()); >+ (fun () -> [valueEntry#text]) >+ | `STRING_LIST | `CUSTOM | `UNKNOWN -> >+ assert false >+ end >+ end >+ in >+ >+ let res = ref None in >+ let cancelCommand () = t#destroy () in >+ let cancelButton = >+ GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in >+ ignore (cancelButton#connect#clicked ~callback:cancelCommand); >+ let okCommand _ = res := Some (newValue ()); t#destroy () in >+ let okButton = >+ GButton.button ~stock:`OK ~packing:t#action_area#add () in >+ ignore (okButton#connect#clicked ~callback:okCommand); >+ okButton#grab_default (); >+ ignore (t#connect#destroy ~callback:GMain.Main.quit); >+ t#show (); >+ GMain.Main.main (); >+ !res >+ >+ >+let markupRe = Str.regexp "<\\([a-z]+\\)>\\|</\\([a-z]+\\)>\\|&\\([a-z]+\\);" >+let entities = >+ [("amp", "&"); ("lt", "<"); ("gt", ">"); ("quot", "\""); ("apos", "'")] >+ >+let rec insertMarkupRec tags (t : #GText.view) s i tl = >+ try >+ let j = Str.search_forward markupRe s i in >+ if j > i then >+ t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i)); >+ let tag = try Some (Str.matched_group 1 s) with Not_found -> None in >+ match tag with >+ Some tag -> >+ insertMarkupRec tags t s (Str.group_end 0) >+ ((try [List.assoc tag tags] with Not_found -> []) :: tl) >+ | None -> >+ let entity = try Some (Str.matched_group 3 s) with Not_found -> None in >+ match entity with >+ None -> >+ insertMarkupRec tags t s (Str.group_end 0) (List.tl tl) >+ | Some ent -> >+ begin try >+ t#buffer#insert ~tags:(List.flatten tl) (List.assoc ent entities) >+ with Not_found -> () end; >+ insertMarkupRec tags t s (Str.group_end 0) tl >+ with Not_found -> >+ let j = String.length s in >+ if j > i then >+ t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i)) >+ >+let insertMarkup tags t s = >+ t#buffer#set_text ""; insertMarkupRec tags t s 0 [] >+ >+let documentPreference ~compact ~packing = >+ let vb = GPack.vbox ~spacing:6 ~packing () in >+ ignore (GMisc.label ~markup:"<b>Documentation</b>" ~xalign:0. >+ ~packing:(vb#pack ~expand:false) ()); >+ let al = GBin.alignment ~packing:(vb#pack ~expand:true ~fill:true) () in >+ al#set_left_padding 12; >+ let columns = if compact then 3 else 2 in >+ let tbl = >+ GPack.table ~rows:2 ~columns ~col_spacings:12 ~row_spacings:6 >+ ~packing:(al#add) () in >+ tbl#misc#set_sensitive false; >+ ignore (GMisc.label ~text:"Short description:" ~xalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); >+ ignore (GMisc.label ~text:"Long description:" ~xalign:0. ~yalign:0. >+ ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); >+ let shortDescr = >+ GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) >+ ~xalign:0. ~selectable:true () in >+ let longDescr = >+ let sw = >+ if compact then >+ GBin.scrolled_window ~height:128 ~width:640 >+ ~packing:(tbl#attach ~left:0 ~top:2 ~right:2 ~expand:`BOTH) >+ ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () >+ else >+ GBin.scrolled_window ~height:128 ~width:640 >+ ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`BOTH) >+ ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () >+ in >+ GText.view ~editable:false ~packing:sw#add ~wrap_mode:`WORD () >+ in >+ let (>>>) x f = f x in >+ let newlineRe = Str.regexp "\n *" in >+ let styleRe = Str.regexp "{\\\\\\([a-z]+\\) \\([^{}]*\\)}" in >+ let verbRe = Str.regexp "\\\\verb|\\([^|]*\\)|" in >+ let argRe = Str.regexp "\\\\ARG{\\([^{}]*\\)}" in >+ let textttRe = Str.regexp "\\\\texttt{\\([^{}]*\\)}" in >+ let emphRe = Str.regexp "\\\\emph{\\([^{}]*\\)}" in >+ let sectionRe = Str.regexp "\\\\sectionref{\\([^{}]*\\)}{\\([^{}]*\\)}" in >+ let emdash = Str.regexp_string "---" in >+ let parRe = Str.regexp "\\\\par *" in >+ let underRe = Str.regexp "\\\\_ *" in >+ let dollarRe = Str.regexp "\\\\\\$ *" in >+ let formatDoc doc = >+ doc >>> >+ Str.global_replace newlineRe " " >>> >+ escapeMarkup >>> >+ Str.global_substitute styleRe >+ (fun s -> >+ try >+ let tag = >+ match Str.matched_group 1 s with >+ "em" -> "i" >+ | "tt" -> "tt" >+ | _ -> raise Exit >+ in >+ Format.sprintf "<%s>%s</%s>" tag (Str.matched_group 2 s) tag >+ with Exit -> >+ Str.matched_group 0 s) >>> >+ Str.global_replace verbRe "<tt>\\1</tt>" >>> >+ Str.global_replace argRe "<tt>\\1</tt>" >>> >+ Str.global_replace textttRe "<tt>\\1</tt>" >>> >+ Str.global_replace emphRe "<i>\\1</i>" >>> >+ 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:"<b>Summary</b>" ~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
<b>You cannot view the attachment while viewing its details because your browser does not support IFRAMEs. <a href="attachment.cgi?id=765686">View the attachment on a separate page</a>.</b>
View Attachment As Diff
View Attachment As Raw
Actions:
View
|
Diff
Attachments on
bug 769341
:
743826
|
743829
|
743832
|
743835
|
743838
|
743841
|
765681
|
765682
|
765683
|
765684
|
765685
| 765686 |
765714
