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