diff --git a/doc/unison-manual.tex b/doc/unison-manual.tex index 2bb8a3a27..3b21bbbe3 100644 --- a/doc/unison-manual.tex +++ b/doc/unison-manual.tex @@ -1963,6 +1963,35 @@ terminal alone and process input a line at a time. \end{itemize} +\SUBSECTION{Interrupting a Synchronization}{intr} + +It is possible to interrupt an ongoing synchronization process before it +completes. Different user interfaces offer different ways of doing it. + +\begin{tkui} +In the graphical user interface the synchronization process can be interrupted +before it is finished by pressing the ``Stop'' button or by closing the window. +The ``Stop'' button causes the onging propagation to be stopped as quickly as +possible while still doing proper cleanup. The application keeps running and a +rescan can be performed or a different profile selected. Closing the window in +the middle of update propagation process will exit the application immediately +without doing proper cleanup; it is therefore not recommended unless the +``Stop'' button does not react quickly enough. +\end{tkui} + +\begin{textui} +When not synchronizing continuously, the text interface terminates when +synchronization is finished normally or due to a fatal error occuring. + +In the text interface, to interrupt synchronization before it is finished, +press ``Ctrl-C'' (or send signal \verb|SIGINT| or \verb|SIGTERM|). This will +interrupt update propagation as quickly as possible but still complete proper +cleanup. If the process does not stop even after pressing ``Ctrl-C'' then keep +doing it repeatedly. This will bypass cleanup procedures and terminates the +process forcibly (similar to \verb|SIGKILL|). Doing so may leave the archives +or replicas in an inconsistent state or locked. +\end{textui} + \SUBSECTION{Exit Code}{exit} When running in the textual mode, Unison returns an exit status, which diff --git a/man/unison.1.in b/man/unison.1.in index 422d91741..60d77a424 100644 --- a/man/unison.1.in +++ b/man/unison.1.in @@ -282,6 +282,24 @@ beginning with #; both are ignored. .Pp When Unison starts, it first reads the profile and then the command line, so command-line options will override settings from the profile. +.Sh TERMINATION +When not synchronizing continuously, the text interface terminates when +synchronization is finished normally or due to a fatal error occuring. +.Pp +In the text interface, to interrupt synchronization before it is finished, +press +.Sy Ctrl-C +(or send signal +.Sy SIGINT +or +.Sy SIGTERM ) . +This will interrupt update propagation as quickly as possible but still +complete proper cleanup. If the process does not stop even after pressing +.Sy Ctrl-C +then keep doing it repeatedly. This will bypass cleanup procedures and +terminates the process forcibly (similar to +.Sy SIGKILL ) . +Doing so may leave the archives or replicas in an inconsistent state or locked. .Sh ENVIRONMENT .Bl -tag .It Ev UNISON diff --git a/src/.depend b/src/.depend index 694ee3017..cbb511033 100644 --- a/src/.depend +++ b/src/.depend @@ -1348,6 +1348,7 @@ uigtk3.cmo : \ common.cmi \ clroot.cmi \ case.cmi \ + abort.cmi \ uigtk3.cmi uigtk3.cmx : \ uutil.cmx \ @@ -1373,6 +1374,7 @@ uigtk3.cmx : \ common.cmx \ clroot.cmx \ case.cmx \ + abort.cmx \ uigtk3.cmi uigtk3.cmi : \ uicommon.cmi @@ -1449,6 +1451,7 @@ uitext.cmo : \ globals.cmi \ fswatchold.cmi \ common.cmi \ + abort.cmi \ uitext.cmi uitext.cmx : \ uutil.cmx \ @@ -1471,6 +1474,7 @@ uitext.cmx : \ globals.cmx \ fswatchold.cmx \ common.cmx \ + abort.cmx \ uitext.cmi uitext.cmi : \ uicommon.cmi diff --git a/src/abort.ml b/src/abort.ml index f356e64fe..2d8e8e0d4 100644 --- a/src/abort.ml +++ b/src/abort.ml @@ -60,12 +60,20 @@ let all () = abortAll := true (****) +let isAll () = !abortAll + +let checkAll () = + if !abortAll then raise (Util.Transient "Aborted by user request") + let check id = debug (fun() -> Util.msg "Checking line %s\n" (Uutil.File.toString id)); - if !abortAll || errorCount id >= Prefs.read maxerrors then begin + checkAll (); + if errorCount id >= Prefs.read maxerrors then begin debug (fun() -> Util.msg "Abort failure for line %s\n" (Uutil.File.toString id)); raise (Util.Transient "Aborted") end -let testException e = (e = Util.Transient "Aborted") +let testException e = + (e = Util.Transient "Aborted") || + (e = Util.Transient "Aborted by user request") diff --git a/src/abort.mli b/src/abort.mli index eca5ed409..9e33736e1 100644 --- a/src/abort.mli +++ b/src/abort.mli @@ -7,6 +7,10 @@ val reset : unit -> unit val file : Uutil.File.t -> unit val all : unit -> unit +(* Check whether stop of all transfers has been requested. *) +val isAll : unit -> bool +val checkAll : unit -> unit (* Raises a transient exception *) + (* Check whether an item is being aborted. A transient exception is raised if this is the case. *) val check : Uutil.File.t -> unit diff --git a/src/copy.ml b/src/copy.ml index 74cdc4074..c968de12a 100644 --- a/src/copy.ml +++ b/src/copy.ml @@ -433,6 +433,7 @@ let copyContents fspathFrom pathFrom fspathTo pathTo fileKind fileLength ido = (fun l -> use_id (fun id -> (* (Util.msg "Copied file %s (%d bytes)\n" (Path.toString pathFrom) l); *) + if fileKind <> `RESS then Abort.checkAll (); Uutil.showProgress id (Uutil.Filesize.ofInt l) "l")); closeFileIn inFd; closeFileOut outFd; @@ -592,6 +593,7 @@ let compress conn (fun () -> showPrefixProgress id fileKind; let showProgress count = + if fileKind <> `RESS then Abort.checkAll (); Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in let compr = match biOpt with @@ -701,6 +703,7 @@ let transferFileContents let outfd = ref None in let infd = ref None in let showProgress count = + if fileKind <> `RESS then Abort.checkAll (); Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in let destFileSize = diff --git a/src/files.ml b/src/files.ml index c1e3f6833..28a37ff8d 100644 --- a/src/files.ml +++ b/src/files.ml @@ -733,10 +733,8 @@ let copy (fun e -> match e with Util.Transient _ -> - if not (Abort.testException e) then begin - Abort.file id; - errors := e :: !errors - end; + if not (Abort.testException e) then Abort.file id; + errors := e :: !errors; Lwt.return (Update.NoArchive, [pFrom]) | _ -> Lwt.fail e) diff --git a/src/remote.ml b/src/remote.ml index 843c2729c..f8e00e843 100644 --- a/src/remote.ml +++ b/src/remote.ml @@ -1851,8 +1851,52 @@ let buildShellConnection shell host userOpt portOpt rootName termInteract = let (term, termPid) = Util.convertUnixErrorsToFatal "starting shell connection" (fun () -> match termInteract with - None -> - (None, System.create_process shellCmd argsarray i1 o2 Unix.stderr) + | None -> + (* Signals generated by the terminal from user input are sent to all + processes in the foreground process group. This means that the ssh + child process will receive SIGINT at the same time as Unison and + close the connection before Unison has the chance to do cleanup with + the remote end. To make matters more complicated, the ssh process + must be in the foreground process group because interaction with the + user is done via the terminal (not via stdin, stdout) and background + processes can't read from the terminal (unless we'd set up a pty + like is done for the GUI). + + Don't let these signals reach ssh by blocking them. + + The signals could be ignored instead of being blocked because ssh + does not set handlers for SIGINT and SIGQUIT if they've been ignored + at startup. But this triggers an error in ssh. The interactive + passphrase reading function captures these signals for the purpose + of restoring terminal settings (echo). When receiving a signal, and + after restoring previous signal handlers, it resends the signal to + itself. But now the signal is ignored and instead of terminating, + the process will continue running as if passphrase reading function + had returned with an empty result. + + Since the ssh process no longer receives the signals generated by + user input we have to make sure that it terminates when Unison does. + This usually happens due to its stdin and stdout being closed, + except for when it is interacting with the user via terminal. To get + around that, an [at_exit] handler is registered to send a SIGTERM + and SIGKILL to the ssh process. (Note, for [at_exit] handlers to + run, unison process must terminate normally, not be killed. For + SIGINT, this means that [Sys.catch_break true] (or an alternative + SIGINT handler) must be set before creating the ssh process.) *) + let pid = Util.blockSignals [Sys.sigint] (fun () -> + System.create_process shellCmd argsarray i1 o2 Unix.stderr) in + let end_ssh () = + let kill_noerr si = try Unix.kill pid si + with Unix.Unix_error _ -> () | Invalid_argument _ -> () in + match Unix.waitpid [WNOHANG] pid with + | (0, _) -> + (* Grace period before killing. Important to give ssh a chance + to restore terminal settings, should that be needed. *) + kill_noerr Sys.sigterm; Unix.sleepf 0.01; kill_noerr Sys.sigkill + | _ | exception Unix.Unix_error _ -> () + in + let () = at_exit end_ssh in + (None, pid) | Some callBack -> Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr) in diff --git a/src/strings.ml b/src/strings.ml index 69012b690..992921395 100644 --- a/src/strings.ml +++ b/src/strings.ml @@ -2728,6 +2728,36 @@ let docs = \032 Setting the dumbtty preference will force Unison to leave the\n\ \032 terminal alone and process input a line at a time.\n\ \n\ + Interrupting a Synchronization\n\ + \n\ + \032 It is possible to interrupt an ongoing synchronization process before\n\ + \032 it completes. Different user interfaces offer different ways of doing\n\ + \032 it.\n\ + \n\ + \032 Graphical Interface:\n\ + \032 * In the graphical user interface the synchronization process can be\n\ + \032 interrupted before it is finished by pressing the \226\128\156Stop\226\128\157 button or\n\ + \032 by closing the window. The \226\128\156Stop\226\128\157 button causes the onging\n\ + \032 propagation to be stopped as quickly as possible while still doing\n\ + \032 proper cleanup. The application keeps running and a rescan can be\n\ + \032 performed or a different profile selected. Closing the window in\n\ + \032 the middle of update propagation process will exit the application\n\ + \032 immediately without doing proper cleanup; it is therefore not\n\ + \032 recommended unless the \226\128\156Stop\226\128\157 button does not react quickly enough.\n\ + \n\ + \032 Textual Interface:\n\ + \032 * When not synchronizing continuously, the text interface terminates\n\ + \032 when synchronization is finished normally or due to a fatal error\n\ + \032 occuring.\n\ + \032 In the text interface, to interrupt synchronization before it is\n\ + \032 finished, press \226\128\156Ctrl-C\226\128\157 (or send signal SIGINT or SIGTERM). This\n\ + \032 will interrupt update propagation as quickly as possible but still\n\ + \032 complete proper cleanup. If the process does not stop even after\n\ + \032 pressing \226\128\156Ctrl-C\226\128\157 then keep doing it repeatedly. This will bypass\n\ + \032 cleanup procedures and terminates the process forcibly (similar to\n\ + \032 SIGKILL). Doing so may leave the archives or replicas in an\n\ + \032 inconsistent state or locked.\n\ + \n\ Exit Code\n\ \n\ \032 When running in the textual mode, Unison returns an exit status, which\n\ diff --git a/src/transport.ml b/src/transport.ml index 227a3ac4a..549091072 100644 --- a/src/transport.ml +++ b/src/transport.ml @@ -55,6 +55,7 @@ let maxThreads () = let run dispenseTask = let runConcurrent limit dispenseTask = + let dispenseTask () = if Abort.isAll () then None else dispenseTask () in let avail = ref limit in let rec runTask thr = Lwt.try_bind thr @@ -156,9 +157,9 @@ let doAction fromRoot fromPath uiFrom propsFrom toRoot toPath uiTo propsTo notDefault id)) - (fun e -> Trace.log + (fun e -> Trace.logonly (Printf.sprintf - "Failed: %s\n" (Util.printException e)); + "Failed [%s]: %s\n" (Path.toString toPath) (Util.printException e)); return ()) let propagate root1 root2 reconItem id showMergeFn = diff --git a/src/ubase/util.ml b/src/ubase/util.ml index 7abb1bf03..2f409a88f 100644 --- a/src/ubase/util.ml +++ b/src/ubase/util.ml @@ -272,6 +272,19 @@ let process_status_to_string = function | Unix.WSIGNALED i -> Printf.sprintf "Killed by signal %d" i | Unix.WSTOPPED i -> Printf.sprintf "Stopped by signal %d" i + +let blockSignals sigs f = + let (prevMask, ok) = + try (Unix.sigprocmask SIG_BLOCK sigs, true) + with Invalid_argument _ -> ([], false) in + let restoreMask () = + if ok then Unix.sigprocmask SIG_SETMASK prevMask |> ignore in + try let r = f () in restoreMask (); r + with e -> + let origbt = Printexc.get_raw_backtrace () in + restoreMask (); + Printexc.raise_with_backtrace e origbt + (*****************************************************************************) (* OS TYPE *) (*****************************************************************************) diff --git a/src/ubase/util.mli b/src/ubase/util.mli index 3a426e26a..330dc93f1 100644 --- a/src/ubase/util.mli +++ b/src/ubase/util.mli @@ -33,6 +33,11 @@ val printException : exn -> string val process_status_to_string : Unix.process_status -> string +(* [blockSignals sigs f] blocks signals [sigs] (if supported by OS), + executes [f ()] and restores the original signal mask before returning + the result of executing [f ()] (value or exception). *) +val blockSignals : int list -> (unit -> 'a) -> 'a + (* ---------------------------------------------------------------------- *) (* Strings *) diff --git a/src/uigtk3.ml b/src/uigtk3.ml index 0e9404637..a23c0e45e 100644 --- a/src/uigtk3.ml +++ b/src/uigtk3.ml @@ -2758,6 +2758,7 @@ let createToplevelWindow () = let grDiff = ref [] in let grGo = ref [] in let grRescan = ref [] in + let grStop = 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 @@ -2766,6 +2767,7 @@ let createToplevelWindow () = grSet grDiff false; grSet grGo false; grSet grRescan false; + grSet grStop false; grSet grDetail false in @@ -3141,7 +3143,7 @@ let createToplevelWindow () = let width = let metrics = mainWindowSW#misc#pango_context#get_metrics () in let w = GPango.to_pixels metrics#approx_digit_width in - max (w * 112) 840 + max (w * 112) 860 in let width = min width (Gdk.Screen.width ~screen:toplevelWindow#screen ()) in (height, width) @@ -3635,6 +3637,7 @@ let createToplevelWindow () = Trace.status "Propagating changes"; Uicommon.transportStart (); + grSet grStop true; let totalLength = Array.fold_left (fun l si -> @@ -3695,6 +3698,7 @@ let createToplevelWindow () = Uicommon.transportItems !theState (fun {ri; _} -> not (Common.isDeletion ri)) uiWrapper; Uicommon.transportItems !theState (fun {ri; _} -> Common.isDeletion ri) uiWrapper; Uicommon.transportFinish (); + grSet grStop false; Trace.showTimer t; commitUpdates (); stopStats (); @@ -3758,19 +3762,29 @@ let createToplevelWindow () = if skippedCount = 0 then [] else [Printf.sprintf "%d skipped" skippedCount] in + let nostartCount = + if not (Abort.isAll ()) then 0 else + Array.fold_left + (fun c si -> if si.whatHappened = None then c + 1 else c) + 0 !theState + in + let nostart = + if nostartCount = 0 then [] else + [Printf.sprintf "%d not started" nostartCount] + 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))); + (String.concat ", " (failures @ partials @ skipped @ nostart))); displayGlobalProgress 0.; grSet grRescan true; make_interactive toplevelWindow; - let totalCount = failureCount + partialCount + skippedCount in + let totalCount = failureCount + partialCount + skippedCount + nostartCount in if totalCount > 0 then begin let format n item sing plur = match n with @@ -3781,10 +3795,12 @@ let createToplevelWindow () = let infos = format failureCount "failure" "" "s" @ format partialCount "partially transferred director" "y" "ies" @ - format skippedCount "skipped item" "" "s" + format skippedCount "skipped item" "" "s" @ + format nostartCount "not started item" "" "s" in let message = - (if failureCount = 0 then "The synchronization was successful.\n\n" + (if failureCount = 0 && nostartCount = 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") ^ @@ -3968,14 +3984,11 @@ let createToplevelWindow () = ~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 ()); - *) + grAdd grStop + (insert_button actionBar ~text:"Stop" + ~stock:`STOP + ~tooltip:"Stop update propagation" + ~callback:Abort.all ()); (********************************************************************* Rescan button diff --git a/src/uitext.ml b/src/uitext.ml index 1cbd52e57..b8eea0f29 100644 --- a/src/uitext.ml +++ b/src/uitext.ml @@ -845,12 +845,57 @@ let doTransport reconItemList = in Uutil.setProgressPrinter showProgress; + let intrcount = ref 0 in + let sigtermHandler _ = + if !intrcount >= 3 then raise Sys.Break; + Abort.all (); + incr intrcount + in + let ctrlCHandler n = + sigtermHandler n; + if !intrcount = 1 then + let s = "\n\nUpdate propagation interrupted. It may take a while \ + to stop.\nIf the process doesn't stop soon then wait or press \ + Ctrl-C\n3 more times to force immediate termination.\n\n\n" in + (* Don't use [Printf.*printf] or [Format.*printf] (or other functions + which use [Stdlib.out_channel]) because this can cause a deadlock + with other outputting functions (in this case most likely at + [Util.set_infos] called in [showProgress]) before OCaml 4.12. *) + try Unix.write_substring Unix.stdout s 0 (String.length s) |> ignore + with Unix.Unix_error _ -> () + in + let stopAtIntr f = + let signal_noerr signa behv = + try Some (Sys.signal signa behv) + with Sys_error _ | Invalid_argument _ -> None + in + let restore_noerr signa = function + | Some prevSig -> ignore (signal_noerr signa prevSig) + | None -> () + in + let prevSigInt = signal_noerr Sys.sigint (Signal_handle ctrlCHandler) in + let prevSigTerm = signal_noerr Sys.sigterm (Signal_handle sigtermHandler) in + let restoreSig () = + (* Set handlers will still raise [Sys.Break]; can ignore errors here. *) + restore_noerr Sys.sigint prevSigInt; + restore_noerr Sys.sigterm prevSigTerm + in + + try f (); restoreSig () + with e -> + let origbt = Printexc.get_raw_backtrace () in + restoreSig (); + Printexc.raise_with_backtrace e origbt + in + Uicommon.transportStart (); let fFailedPaths = ref [] in let fPartialPaths = ref [] in + let notstarted = ref (Array.length items) in let uiWrapper i item = Lwt.try_bind - (fun () -> Transport.transportItem item.ri + (fun () -> decr notstarted; + Transport.transportItem item.ri (Uutil.File.ofLine i) verifyMerge) (fun () -> if partiallyProblematic item.ri && not (problematic item.ri) then @@ -872,14 +917,16 @@ let doTransport reconItemList = return () | _ -> fail e) in - Uicommon.transportItems items (fun {ri; _} -> not (Common.isDeletion ri)) uiWrapper; - Uicommon.transportItems items (fun {ri; _} -> Common.isDeletion ri) uiWrapper; + stopAtIntr begin fun () -> + Uicommon.transportItems items (fun {ri; _} -> not (Common.isDeletion ri)) uiWrapper; + Uicommon.transportItems items (fun {ri; _} -> Common.isDeletion ri) uiWrapper + end; Uicommon.transportFinish (); Uutil.setProgressPrinter (fun _ _ _ -> ()); Util.set_infos ""; - (Safelist.rev !fFailedPaths, Safelist.rev !fPartialPaths) + (Safelist.rev !fFailedPaths, Safelist.rev !fPartialPaths, !notstarted, !intrcount > 0) let setWarnPrinterForInitialization()= Util.warnPrinter := @@ -917,8 +964,8 @@ let formatStatus major minor = s let rec interactAndPropagateChanges prevItemList reconItemList - : bool * bool * bool * (Path.t list) - (* anySkipped?, anyPartial?, anyFailures?, failingPaths *) = + : bool * bool * bool * bool * (Path.t list) + (* anySkipped?, anyPartial?, anyFailures?, anyCancels?, failingPaths *) = let (proceed,newReconItemList) = interact prevItemList reconItemList in let (updatesToDo, skipped) = Safelist.fold_left @@ -926,21 +973,41 @@ let rec interactAndPropagateChanges prevItemList reconItemList if problematic ri then (howmany, skipped + 1) else (howmany + 1, skipped)) (0, 0) newReconItemList in + let doTransp newReconItemList = + try + doTransport newReconItemList + with e -> + let origbt = Printexc.get_raw_backtrace () in + let summary = + "\nSynchronization " + ^ (color `Failure) + ^ (match e with Sys.Break -> "interrupted" | _ -> "failed") + ^ (color `Reset) + ^ (try let tm = Util.localtime (Util.time ()) in + Printf.sprintf " at %02d:%02d:%02d" + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec with _ -> "") + ^ (match e with Sys.Break -> " by user request" | _ -> " due to a fatal error") + ^ "\n\n" + in + Trace.log_color summary; + Printexc.raise_with_backtrace e origbt + in let doit() = if not (Prefs.read Globals.batch || Prefs.read Trace.terse) then newLine(); if not (Prefs.read Trace.terse) then Trace.status "Propagating updates"; let timer = Trace.startTimer "Transmitting all files" in - let (failedPaths, partialPaths) = doTransport newReconItemList in + let (failedPaths, partialPaths, notstarted, intr) = doTransp newReconItemList in let failures = Safelist.length failedPaths in let partials = Safelist.length partialPaths in Trace.showTimer timer; if not (Prefs.read Trace.terse) then Trace.status "Saving synchronizer state"; Update.commitUpdates (); - let trans = updatesToDo - failures in + let trans = updatesToDo - notstarted - failures in let summary = Printf.sprintf - "Synchronization %s at %s (%d item%s transferred, %s%s, %s)" - (if failures = 0 then (color `Success) ^ "complete" ^ (color `Reset) else (color `Failure) ^ "incomplete" ^ (color `Reset)) + "Synchronization %s at %s (%d item%s transferred, %s%s, %s%s)" + (if failures = 0 && notstarted = 0 then (color `Success) ^ "complete" ^ (color `Reset) + else (color `Failure) ^ "incomplete" ^ (color `Reset)) (let tm = Util.localtime (Util.time()) in Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec) @@ -950,7 +1017,8 @@ let rec interactAndPropagateChanges prevItemList reconItemList else "") (if skipped = 0 then "0 skipped" else (color `Information) ^ (Printf.sprintf "%d skipped" skipped) ^ (color `Reset)) - (if failures = 0 then "0 failed" else (color `Failure) ^ (Printf.sprintf "%d failed" failures) ^ (color `Reset)) in + (if failures = 0 then "0 failed" else (color `Failure) ^ (Printf.sprintf "%d failed" failures) ^ (color `Reset)) + (if notstarted = 0 then "" else ", " ^ (color `Information) ^ (Printf.sprintf "%d not started" notstarted) ^ (color `Reset)) in Trace.log_color (summary ^ "\n"); if skipped>0 then Safelist.iter @@ -971,7 +1039,8 @@ let rec interactAndPropagateChanges prevItemList reconItemList Safelist.iter (fun p -> alwaysDisplayAndLog (" failed: " ^ (Path.toString p))) failedPaths; - (skipped > 0, partials > 0, failures > 0, failedPaths) in + if intr then raise Sys.Break; (* Make sure repeat mode is stopped *) + (skipped > 0, partials > 0, failures > 0, notstarted > 0, failedPaths) in if updatesToDo = 0 then begin (* BCP (3/09): We need to commit the archives even if there are no updates to propagate because some files (in fact, if we've @@ -1006,7 +1075,7 @@ let rec interactAndPropagateChanges prevItemList reconItemList | _ -> ()) newReconItemList end; - (skipped > 0, false, false, []) + (skipped > 0, false, false, false, []) end else if proceed=ProceedImmediately then begin doit() end else @@ -1133,9 +1202,9 @@ let synchronizeOnce ?wantWatcher pathsOpt = (Uicommon.perfectExit, []) end else begin checkForDangerousPath dangerousPaths; - let (anySkipped, anyPartial, anyFailures, failedPaths) = + let (anySkipped, anyPartial, anyFailures, anyCancel, failedPaths) = interactAndPropagateChanges [] reconItemList in - let exitStatus = Uicommon.exitCode(anySkipped || anyPartial,anyFailures) in + let exitStatus = Uicommon.exitCode (anySkipped || anyPartial || anyCancel, anyFailures) in (exitStatus, failedPaths) end @@ -1374,6 +1443,7 @@ let rec start interface = if interface <> Uicommon.Text then Util.msg "This Unison binary only provides the text GUI...\n"; begin try + Sys.catch_break true; (* Just to make sure something is there... *) setWarnPrinterForInitialization(); let errorOut s =