[Unison-hackers] [unison-svn] r401 - in trunk/src: . lwt
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Fri Jan 15 03:29:27 EST 2010
Author: vouillon
Date: 2010-01-15 03:29:26 -0500 (Fri, 15 Jan 2010)
New Revision: 401
Modified:
trunk/src/.depend
trunk/src/RECENTNEWS
trunk/src/lwt/lwt_unix.ml
trunk/src/lwt/lwt_unix.mli
trunk/src/mkProjectInfo.ml
trunk/src/os.ml
trunk/src/os.mli
trunk/src/remote.ml
trunk/src/terminal.ml
trunk/src/terminal.mli
trunk/src/uicommon.ml
trunk/src/uigtk2.ml
trunk/src/update.ml
Log:
* GTK UI:
- take into account the "height" preference again
- the internal list of selected reconciler item was not always in
sync with what was displayed (GTK bug?); workaround implemented
* Do not display "Looking for change" messages during propagation
(when checking the targe is unchanged) but only during update detection
* Now use an opaque datatype for file descriptors in Lwt
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/.depend 2010-01-15 08:29:26 UTC (rev 401)
@@ -32,7 +32,7 @@
stasher.cmi: update.cmi ubase/prefs.cmi path.cmi os.cmi fspath.cmi
strings.cmi:
system.cmi: system/system_intf.cmo
-terminal.cmi:
+terminal.cmi: lwt/lwt_unix.cmi
test.cmi:
transfer.cmi: uutil.cmi lwt/lwt.cmi bytearray.cmi
transport.cmi: uutil.cmi lwt/lwt.cmi common.cmi
@@ -113,6 +113,8 @@
globals.cmx: ubase/util.cmx ubase/trace.cmx ubase/safelist.cmx remote.cmx \
ubase/prefs.cmx pred.cmx path.cmx os.cmx name.cmx lwt/lwt_util.cmx \
lwt/lwt_unix.cmx lwt/lwt.cmx common.cmx clroot.cmx globals.cmi
+library_info.cmo:
+library_info.cmx:
linkgtk.cmo: uigtk.cmi main.cmo
linkgtk.cmx: uigtk.cmx main.cmx
linkgtk2.cmo: uigtk2.cmi main.cmo
@@ -185,10 +187,10 @@
strings.cmx: strings.cmi
system.cmo: system.cmi
system.cmx: system.cmi
-terminal.cmo: system.cmi ubase/safelist.cmi ubase/rx.cmi lwt/lwt_unix.cmi \
- lwt/lwt.cmi terminal.cmi
-terminal.cmx: system.cmx ubase/safelist.cmx ubase/rx.cmx lwt/lwt_unix.cmx \
- lwt/lwt.cmx terminal.cmi
+terminal.cmo: system.cmi ubase/rx.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
+ terminal.cmi
+terminal.cmx: system.cmx ubase/rx.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
+ terminal.cmi
test.cmo: uutil.cmi ubase/util.cmi update.cmi uicommon.cmi transport.cmi \
ubase/trace.cmi stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi \
ubase/prefs.cmi path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi \
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/RECENTNEWS 2010-01-15 08:29:26 UTC (rev 401)
@@ -1,3 +1,14 @@
+CHANGES FROM VERSION 2.39.4
+
+* GTK UI:
+ - take into account the "height" preference again
+ - the internal list of selected reconciler item was not always in
+ sync with what was displayed (GTK bug?); workaround implemented
+* Do not display "Looking for change" messages during propagation
+ (when checking the targe is unchanged) but only during update detection
+* Now use an opaque datatype for file descriptors in Lwt
+
+-------------------------------
CHANGES FROM VERSION 2.39.0
* Mac GUIs (NEED TESTING):
Modified: trunk/src/lwt/lwt_unix.ml
===================================================================
--- trunk/src/lwt/lwt_unix.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/lwt/lwt_unix.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -57,6 +57,10 @@
| _ ->
()
+type file_descr = Unix.file_descr
+
+let of_unix_file_descr fd = if not windows_hack then Unix.set_nonblock fd; fd
+
let inputs = ref []
let outputs = ref []
let wait_children = ref []
@@ -225,18 +229,32 @@
| e ->
Lwt.fail e
+(*
let pipe () =
- let (out_fd, in_fd) as fd_pair = Unix.pipe() in
+ let (in_fd, out_fd) as fd_pair = Unix.pipe() in
if not windows_hack then begin
Unix.set_nonblock in_fd;
Unix.set_nonblock out_fd
end;
- Lwt.return fd_pair
+ fd_pair
+*)
+let pipe_in () =
+ let (in_fd, out_fd) as fd_pair = Unix.pipe() in
+ if not windows_hack then
+ Unix.set_nonblock in_fd;
+ fd_pair
+
+let pipe_out () =
+ let (in_fd, out_fd) as fd_pair = Unix.pipe() in
+ if not windows_hack then
+ Unix.set_nonblock out_fd;
+ fd_pair
+
let socket dom typ proto =
let s = Unix.socket dom typ proto in
if not windows_hack then Unix.set_nonblock s;
- Lwt.return s
+ s
let socketpair dom typ proto =
let (s1, s2) as spair = Unix.socketpair dom typ proto in
@@ -245,6 +263,12 @@
end;
Lwt.return spair
+let bind = Unix.bind
+let setsockopt = Unix.setsockopt
+let listen = Unix.listen
+let close = Unix.close
+let set_close_on_exec = Unix.set_close_on_exec
+
let accept ch =
let res = Lwt.wait () in
inputs := (ch, `Accept res) :: !inputs;
@@ -398,29 +422,29 @@
| id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
- Lwt.bind (pipe ()) (fun (in_read, in_write) ->
+ let (in_read, in_write) = pipe_in () in
let inchan = Unix.in_channel_of_descr in_read in
open_proc cmd (Process_in inchan) Unix.stdin in_write [in_read];
Unix.close in_write;
- Lwt.return inchan)
+ Lwt.return inchan
let open_process_out cmd =
- Lwt.bind (pipe ()) (fun (out_read, out_write) ->
+ let (out_read, out_write) = pipe_out () in
let outchan = Unix.out_channel_of_descr out_write in
open_proc cmd (Process_out outchan) out_read Unix.stdout [out_write];
Unix.close out_read;
- Lwt.return outchan)
+ Lwt.return outchan
let open_process cmd =
- Lwt.bind (pipe ()) (fun (in_read, in_write) ->
- Lwt.bind (pipe ()) (fun (out_read, out_write) ->
+ let (in_read, in_write) = pipe_in () in
+ let (out_read, out_write) = pipe_out () in
let inchan = Unix.in_channel_of_descr in_read in
let outchan = Unix.out_channel_of_descr out_write in
open_proc cmd (Process(inchan, outchan)) out_read in_write
[in_read; out_write];
Unix.close out_read;
Unix.close in_write;
- Lwt.return (inchan, outchan)))
+ Lwt.return (inchan, outchan)
(* FIX: Subprocesses that use /dev/tty to print things on the terminal
will NOT have this output captured and returned to the caller of this
@@ -430,7 +454,7 @@
principle, by writing a little C code that opens /dev/tty and then uses
the TIOCNOTTY ioctl control to detach the terminal. *)
-let open_proc_full cmd env proc output input error toclose =
+let open_proc_full cmd env proc input output error toclose =
match Unix.fork () with
0 -> Unix.dup2 input Unix.stdin; Unix.close input;
Unix.dup2 output Unix.stdout; Unix.close output;
@@ -440,18 +464,18 @@
| id -> Hashtbl.add popen_processes proc id
let open_process_full cmd env =
- Lwt.bind (pipe ()) (fun (in_read, in_write) ->
- Lwt.bind (pipe ()) (fun (out_read, out_write) ->
- Lwt.bind (pipe ()) (fun (err_read, err_write) ->
- let inchan = Unix.out_channel_of_descr in_write in
- let outchan = Unix.in_channel_of_descr out_read in
+ let (in_read, in_write) = pipe_in () in
+ let (out_read, out_write) = pipe_out () in
+ let (err_read, err_write) = pipe_in () in
+ let inchan = Unix.in_channel_of_descr in_read in
+ let outchan = Unix.out_channel_of_descr out_write in
let errchan = Unix.in_channel_of_descr err_read in
- open_proc_full cmd env (Process_full(outchan, inchan, errchan))
- out_write in_read err_write [in_write; out_read; err_read];
- Unix.close out_write;
- Unix.close in_read;
+ open_proc_full cmd env (Process_full(inchan, outchan, errchan))
+ out_read in_write err_write [in_write; out_read; err_read];
+ Unix.close out_read;
+ Unix.close in_write;
Unix.close err_write;
- Lwt.return (outchan, inchan, errchan))))
+ Lwt.return (inchan, outchan, errchan)
let find_proc_id fun_name proc =
try
Modified: trunk/src/lwt/lwt_unix.mli
===================================================================
--- trunk/src/lwt/lwt_unix.mli 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/lwt/lwt_unix.mli 2010-01-15 08:29:26 UTC (rev 401)
@@ -30,16 +30,28 @@
this library, you must first turn them into non-blocking mode
using [Unix.set_nonblock]. *)
-val read : Unix.file_descr -> string -> int -> int -> int Lwt.t
-val write : Unix.file_descr -> string -> int -> int -> int Lwt.t
-val pipe : unit -> (Unix.file_descr * Unix.file_descr) Lwt.t
+type file_descr
+
+val of_unix_file_descr : Unix.file_descr -> file_descr
+
+val read : file_descr -> string -> int -> int -> int Lwt.t
+val write : file_descr -> string -> int -> int -> int Lwt.t
+val wait_read : file_descr -> unit Lwt.t
+val wait_write : file_descr -> unit Lwt.t
+val pipe_in : unit -> file_descr * Unix.file_descr
+val pipe_out : unit -> Unix.file_descr * file_descr
val socket :
- Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr Lwt.t
+ Unix.socket_domain -> Unix.socket_type -> int -> file_descr
val socketpair :
Unix.socket_domain -> Unix.socket_type -> int ->
- (Unix.file_descr * Unix.file_descr) Lwt.t
-val accept : Unix.file_descr -> (Unix.file_descr * Unix.sockaddr) Lwt.t
-val connect : Unix.file_descr -> Unix.sockaddr -> unit Lwt.t
+ (file_descr * file_descr) Lwt.t
+val bind : file_descr -> Unix.sockaddr -> unit
+val setsockopt : file_descr -> Unix.socket_bool_option -> bool -> unit
+val accept : file_descr -> (file_descr * Unix.sockaddr) Lwt.t
+val connect : file_descr -> Unix.sockaddr -> unit Lwt.t
+val listen : file_descr -> int -> unit
+val close : file_descr -> unit
+val set_close_on_exec : file_descr -> unit
val wait : unit -> (int * Unix.process_status) Lwt.t
val waitpid : Unix.wait_flag list -> int -> (int * Unix.process_status) Lwt.t
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/mkProjectInfo.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -42,7 +42,7 @@
(* ---------------------------------------------------------------------- *)
(* You shouldn't need to edit below. *)
-let revisionString = "$Rev: 396$";;
+let revisionString = "$Rev: 400$";;
(* extract a substring using a regular expression *)
let extract_str re str =
@@ -101,3 +101,4 @@
+
Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/os.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -342,19 +342,3 @@
let tempPath ?(fresh=true) fspath path =
genTempPath fresh fspath path tempFilePrefix !tempFileSuffix
-
-(*****************************************************************************)
-(* INTERRUPTED SYSTEM CALLS *)
-(*****************************************************************************)
-(* Needed because in lwt/lwt_unix.ml we set a signal handler for SIG_CHLD,
- which means that slow system calls can be interrupted to handle
- SIG_CHLD. We want to restart these system calls. It would be much
- better to do this using SA_RESTART, however, ocaml's Unix module does
- not support this, probably because it isn't nicely portable. *)
-let accept fd =
- let rec loop () =
- try Unix.accept fd
- with Unix.Unix_error(Unix.EINTR,_,_) -> loop() in
- loop()
-
-
Modified: trunk/src/os.mli
===================================================================
--- trunk/src/os.mli 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/os.mli 2010-01-15 08:29:26 UTC (rev 401)
@@ -45,7 +45,3 @@
Fspath.t -> Path.local -> (* coordinates of file to fingerprint *)
Fileinfo.t -> (* old fileinfo *)
fullfingerprint (* current fingerprint *)
-
-(* Versions of system calls that will restart when interrupted by
- signal handling *)
-val accept : Unix.file_descr -> (Unix.file_descr * Unix.sockaddr)
Modified: trunk/src/remote.ml
===================================================================
--- trunk/src/remote.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/remote.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -42,8 +42,8 @@
Threads behave in a very controlled way: they only perform possibly
blocking I/Os through the remote module, and never call
Lwt_unix.yield. This mean that when one side gives up its right to
- write, we know that no longer how much we wait, it would not have
- any thing to write. This ensures that there will be no deadlock.
+ write, we know that no matter how long we wait, it will not have
+ anything to write. This ensures that there is no deadlock.
A more robust protocol would be to give up write permission
whenever idle (not just after having sent at least one message).
But then, there is the risk that the two sides exchange spurious
@@ -110,7 +110,7 @@
(* I/O buffers *)
type ioBuffer =
- { channel : Unix.file_descr;
+ { channel : Lwt_unix.file_descr;
buffer : string;
mutable length : int }
@@ -368,10 +368,6 @@
(* Initialize the connection *)
let setupIO isServer inCh outCh =
- if not windowsHack then begin
- Unix.set_nonblock inCh;
- Unix.set_nonblock outCh
- end;
makeConnection isServer inCh outCh
(* XXX *)
@@ -989,67 +985,81 @@
let rec findFirst f l =
match l with
- [] -> None
- | x :: r -> match f x with
+ [] -> Lwt.return None
+ | x :: r -> f x >>= fun v ->
+ match v with
None -> findFirst f r
- | Some _ as v -> v
+ | Some _ as v -> Lwt.return v
let buildSocket host port kind =
let attemptCreation ai =
- try
- let socket =
- Unix.socket ai.Unix.ai_family ai.Unix.ai_socktype ai.Unix.ai_protocol
- in
- try
- begin match kind with
- `Connect ->
- (* Connect to the remote host *)
- Unix.connect socket ai.Unix.ai_addr
- | `Bind ->
- (* Allow reuse of local addresses for bind *)
- Unix.setsockopt socket Unix.SO_REUSEADDR true;
- (* Bind the socket to portnum on the local host *)
- Unix.bind socket ai.Unix.ai_addr;
- (* Start listening, allow up to 1 pending request *)
- Unix.listen socket 1
- end;
- Some socket
- with Unix.Unix_error _ as e ->
- Unix.close socket;
- raise e
- with Unix.Unix_error (error, _, _) ->
- begin match error with
- Unix.EAFNOSUPPORT | Unix.EPROTONOSUPPORT | Unix.EINVAL ->
- ()
- | _ ->
- let msg =
- match kind with
- `Connect ->
- Printf.sprintf "Can't connect to server (%s:%s): %s"
- host port (Unix.error_message error)
- | `Bind ->
- Printf.sprintf
- "Can't bind socket to port %s at address [%s]: %s\n"
- port
- (match ai.Unix.ai_addr with
- Unix.ADDR_INET (addr, _) -> Unix.string_of_inet_addr addr
- | _ -> assert false)
- (Unix.error_message error)
- in
- Util.warn msg
- end;
- None
+ Lwt.catch
+ (fun () ->
+ let socket =
+ Lwt_unix.socket
+ ai.Unix.ai_family ai.Unix.ai_socktype ai.Unix.ai_protocol
+ in
+ Lwt.catch
+ (fun () ->
+ begin match kind with
+ `Connect ->
+ (* Connect (synchronously) to the remote host *)
+ Lwt_unix.connect socket ai.Unix.ai_addr
+ | `Bind ->
+ (* Allow reuse of local addresses for bind *)
+ Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
+ (* Bind the socket to portnum on the local host *)
+ Lwt_unix.bind socket ai.Unix.ai_addr;
+ (* Start listening, allow up to 1 pending request *)
+ Lwt_unix.listen socket 1;
+ Lwt.return ()
+ end >>= fun () ->
+ Lwt.return (Some socket))
+ (fun e ->
+ match e with
+ Unix.Unix_error _ ->
+ Lwt_unix.close socket;
+ Lwt.fail e
+ | _ ->
+ Lwt.fail e))
+ (fun e ->
+ match e with
+ Unix.Unix_error (error, _, _) ->
+ begin match error with
+ Unix.EAFNOSUPPORT | Unix.EPROTONOSUPPORT | Unix.EINVAL ->
+ ()
+ | _ ->
+ let msg =
+ match kind with
+ `Connect ->
+ Printf.sprintf "Can't connect to server (%s:%s): %s"
+ host port (Unix.error_message error)
+ | `Bind ->
+ Printf.sprintf
+ "Can't bind socket to port %s at address [%s]: %s\n"
+ port
+ (match ai.Unix.ai_addr with
+ Unix.ADDR_INET (addr, _) ->
+ Unix.string_of_inet_addr addr
+ | _ ->
+ assert false)
+ (Unix.error_message error)
+ in
+ Util.warn msg
+ end;
+ Lwt.return None
+ | _ ->
+ Lwt.fail e)
in
let options =
match kind with
`Connect -> [ Unix.AI_SOCKTYPE Unix.SOCK_STREAM ]
| `Bind -> [ Unix.AI_SOCKTYPE Unix.SOCK_STREAM ; Unix.AI_PASSIVE ]
in
- match
- findFirst attemptCreation (Unix.getaddrinfo host port options)
- with
+ findFirst attemptCreation (Unix.getaddrinfo host port options) >>= fun res ->
+ match res with
Some socket ->
- socket
+ Lwt.return socket
| None ->
let msg =
match kind with
@@ -1063,12 +1073,11 @@
Printf.sprintf "Can't bind socket to port %s on host %s"
port host
in
- raise (Util.Fatal msg)
+ Lwt.fail (Util.Fatal msg)
let buildSocketConnection host port =
- Util.convertUnixErrorsToFatal "canonizeRoot" (fun () ->
- let socket = buildSocket host port `Connect in
- initConnection socket socket)
+ buildSocket host port `Connect >>= fun socket ->
+ initConnection socket socket
let buildShellConnection shell host userOpt portOpt rootName termInteract =
let remoteCmd =
@@ -1109,13 +1118,13 @@
Safelist.concat
(Safelist.map (fun s -> Util.splitIntoWords s ' ') preargs) in
let argsarray = Array.of_list args in
- let (i1,o1) = Unix.pipe() in
- let (i2,o2) = Unix.pipe() in
+ let (i1,o1) = Lwt_unix.pipe_out () in
+ let (i2,o2) = Lwt_unix.pipe_in () in
(* We need to make sure that there is only one reader and one
writer by pipe, so that, when one side of the connection
dies, the other side receives an EOF or a SIGPIPE. *)
- Unix.set_close_on_exec i2;
- Unix.set_close_on_exec o1;
+ Lwt_unix.set_close_on_exec i2;
+ Lwt_unix.set_close_on_exec o1;
(* We add CYGWIN=binmode to the environment before calling
ssh because the cygwin implementation on Windows sometimes
puts the pipe in text mode (which does end of line
@@ -1212,11 +1221,11 @@
terminal interaction might be required (for ssh password) *)
type preconnection =
(Unix.file_descr
+ * Lwt_unix.file_descr
+ * Lwt_unix.file_descr
* Unix.file_descr
- * Unix.file_descr
- * Unix.file_descr
* string option
- * Unix.file_descr option
+ * Lwt_unix.file_descr option
* Clroot.clroot
* int)
let openConnectionStart clroot =
@@ -1293,13 +1302,13 @@
Safelist.concat
(Safelist.map (fun s -> Util.splitIntoWords s ' ') preargs) in
let argsarray = Array.of_list args in
- let (i1,o1) = Unix.pipe() in
- let (i2,o2) = Unix.pipe() in
+ let (i1,o1) = Lwt_unix.pipe_out() in
+ let (i2,o2) = Lwt_unix.pipe_in() in
(* We need to make sure that there is only one reader and one
writer by pipe, so that, when one side of the connection
dies, the other side receives an EOF or a SIGPIPE. *)
- Unix.set_close_on_exec i2;
- Unix.set_close_on_exec o1;
+ Lwt_unix.set_close_on_exec i2;
+ Lwt_unix.set_close_on_exec o1;
(* We add CYGWIN=binmode to the environment before calling
ssh because the cygwin implementation on Windows sometimes
puts the pipe in text mode (which does end of line
@@ -1325,8 +1334,9 @@
let openConnectionReply = function
(i1,i2,o1,o2,s,Some fdTerm,clroot,pid) ->
(fun response ->
- (* FIX: should loop on write, watch for EINTR, etc. *)
- ignore(Unix.write fdTerm (response ^ "\n") 0 (String.length response + 1)))
+ (* FIX: should loop until everything is written... *)
+ ignore (Lwt_unix.run (Lwt_unix.write fdTerm (response ^ "\n") 0
+ (String.length response + 1))))
| _ -> (fun _ -> ())
let openConnectionEnd (i1,i2,o1,o2,s,_,clroot,pid) =
@@ -1344,11 +1354,12 @@
let openConnectionCancel (i1,i2,o1,o2,s,fdopt,clroot,pid) =
try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ();
try Unix.close i1 with Unix.Unix_error _ -> ();
- try Unix.close i2 with Unix.Unix_error _ -> ();
- try Unix.close o1 with Unix.Unix_error _ -> ();
+ try Lwt_unix.close i2 with Unix.Unix_error _ -> ();
+ try Lwt_unix.close o1 with Unix.Unix_error _ -> ();
try Unix.close o2 with Unix.Unix_error _ -> ();
match fdopt with
- None -> () | Some fd -> (try Unix.close fd with Unix.Unix_error _ -> ())
+ None -> ()
+ | Some fd -> (try Lwt_unix.close fd with Unix.Unix_error _ -> ())
(****************************************************************************)
(* SERVER-MODE COMMAND PROCESSING LOOP *)
@@ -1372,9 +1383,9 @@
(* Send header indicating to the client that it has successfully
connected to the server *)
let conn = setupIO true in_ch out_ch in
- try
- Lwt_unix.run
- (dump conn [(Bytearray.of_string connectionHeader, 0,
+ Lwt.catch
+ (fun e ->
+ dump conn [(Bytearray.of_string connectionHeader, 0,
String.length connectionHeader)]
>>= (fun () ->
(* Set the local warning printer to make an RPC to the client and
@@ -1385,9 +1396,13 @@
Some (fun str -> Lwt_unix.run (forwardMsgToClient conn str));
receive conn >>=
Lwt.wait))
-(* debug (fun () -> Util.msg "Should never happen\n") *)
- with Util.Fatal "Lost connection with the server" ->
- debug (fun () -> Util.msg "Connection closed by the client\n")
+ (fun e ->
+ match e with
+ Util.Fatal "Lost connection with the server" ->
+ debug (fun () -> Util.msg "Connection closed by the client\n");
+ Lwt.return ()
+ | _ ->
+ Lwt.fail e)
let killServer =
Prefs.createBool "killserver" false
@@ -1408,23 +1423,25 @@
for a request. Each request is processed by commandLoop. When a
session finishes, the server waits for another request. *)
let waitOnPort hostOpt port =
- Util.convertUnixErrorsToFatal
- "waiting on port"
+ Util.convertUnixErrorsToFatal "waiting on port"
(fun () ->
- let host = match hostOpt with
- Some host -> host
- | None -> "" in
- let listening = buildSocket host port `Bind in
- Util.msg "server started\n";
- while
- (* Accept a connection *)
- let (connected,_) = Os.accept listening in
- Unix.setsockopt connected Unix.SO_KEEPALIVE true;
- commandLoop connected connected;
- (* The client has closed its end of the connection *)
- begin try Unix.close connected with Unix.Unix_error _ -> () end;
- not (Prefs.read killServer)
- do () done)
+ Lwt_unix.run
+ (let host = match hostOpt with
+ Some host -> host
+ | None -> "" in
+ buildSocket host port `Bind >>= fun listening ->
+ Util.msg "server started\n";
+ let rec handleClients () =
+ (* Accept a connection *)
+ Lwt_unix.accept listening >>= fun (connected,_) ->
+ Lwt_unix.setsockopt connected Unix.SO_KEEPALIVE true;
+ commandLoop connected connected >>= fun () ->
+ (* The client has closed its end of the connection *)
+ begin try Lwt_unix.close connected with Unix.Unix_error _ -> () end;
+ if Prefs.read killServer then Lwt.return () else
+ handleClients ()
+ in
+ handleClients ()))
let beAServer () =
begin try
@@ -1437,4 +1454,7 @@
"Environment variable HOME unbound: \
executing server in current directory\n"
end;
- commandLoop Unix.stdin Unix.stdout
+ Lwt_unix.run
+ (commandLoop
+ (Lwt_unix.of_unix_file_descr Unix.stdin)
+ (Lwt_unix.of_unix_file_descr Unix.stdout))
Modified: trunk/src/terminal.ml
===================================================================
--- trunk/src/terminal.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/terminal.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -209,41 +209,36 @@
end
| childPid ->
Unix.close slaveFd;
- (Some masterFd, childPid)
+ (Some (Lwt_unix.of_unix_file_descr masterFd), childPid)
end
-let rec select a b c d =
- try Unix.select a b c d
- with Unix.Unix_error(Unix.EINTR,_,_) -> select a b c d
+let (>>=) = Lwt.bind
(* Wait until there is input. If there is terminal input s,
return Some s. Otherwise, return None. *)
let rec termInput fdTerm fdInput =
- let (ready,_,_) = select [fdTerm;fdInput] [] [] (-1.0) in
- if not(Safelist.exists (fun x -> x=fdTerm) ready) then None else
- (* there's input waiting on the terminal *)
- (* read a line of input *)
- let msg =
- let n = 1024 in (* Assume length of input from terminal < n *)
- let s = String.create n in
- let howmany =
- let rec loop() =
- try Unix.read fdTerm s 0 n
- with Unix.Unix_error(Unix.EINTR,_,_) -> loop() in
- loop() in
- if howmany <= 0 then "" else
- String.sub s 0 howmany in
- let len = String.length msg in
- if len = 0 then None (* the terminal has been closed *)
- else if len = 2 && msg.[0] = '\r' && msg.[1] = '\n' then
- termInput fdTerm fdInput
- else Some msg
+ let buf = String.create 10000 in
+ let rec readPrompt () =
+ Lwt_unix.read fdTerm buf 0 10000 >>= fun len ->
+ if len = 0 then
+ (* The remote end is dead *)
+ Lwt.return None
+ else
+ let query = String.sub buf 0 len in
+ if query = "\r\n" then
+ readPrompt ()
+ else
+ Lwt.return (Some query)
+ in
+ let connectionEstablished () =
+ Lwt_unix.wait_read fdInput >>= fun () -> Lwt.return None
+ in
+ Lwt_unix.run
+ (Lwt.choose
+ [readPrompt (); connectionEstablished ()])
-let (>>=) = Lwt.bind
-
(* Read messages from the terminal and use the callback to get an answer *)
let handlePasswordRequests fdTerm callback =
- Unix.set_nonblock fdTerm;
let buf = String.create 10000 in
let rec loop () =
Lwt_unix.read fdTerm buf 0 10000 >>= (fun len ->
Modified: trunk/src/terminal.mli
===================================================================
--- trunk/src/terminal.mli 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/terminal.mli 2010-01-15 08:29:26 UTC (rev 401)
@@ -5,17 +5,17 @@
val create_session :
string -> string array ->
Unix.file_descr -> Unix.file_descr -> Unix.file_descr ->
- Unix.file_descr option * int
+ Lwt_unix.file_descr option * int
(* termInput fdTerm fdInput
Wait until there is input on at least one file descriptor.
If there is terminal input s, return Some s.
Otherwise, return None. *)
val termInput :
- Unix.file_descr -> Unix.file_descr -> string option
+ Lwt_unix.file_descr -> Lwt_unix.file_descr -> string option
val handlePasswordRequests :
- Unix.file_descr -> (string -> string) -> unit
+ Lwt_unix.file_descr -> (string -> string) -> unit
(* For recognizing messages from OpenSSH *)
val password : string -> bool
Modified: trunk/src/uicommon.ml
===================================================================
--- trunk/src/uicommon.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/uicommon.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -50,7 +50,7 @@
(* This has to be here rather than in uigtk.ml, because it is part of what
gets sent to the server at startup *)
let mainWindowHeight =
- Prefs.createInt "height" 20
+ Prefs.createInt "height" 15
"!height (in lines) of main window in graphical interface"
("Used to set the height (in lines) of the main window in the graphical "
^ "user interface.")
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/uigtk2.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -1996,11 +1996,13 @@
~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 ||
+ all || List.mem nm shownPrefs ||
(let (_, _, basic) = Prefs.documentation nm in basic &&
not (List.mem nm hiddenPrefs))
then begin
@@ -2379,7 +2381,7 @@
in
let hb = GPack.hbox ~spacing:12 ~packing:(lvb#add) () in
let sw =
- GBin.scrolled_window ~packing:(hb#pack ~expand:true) ~height:200
+ 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
@@ -2612,7 +2614,7 @@
let summaryBox ~parent ~title ~message ~f =
let t =
GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true
- ~allow_grow:false () in
+ ~allow_grow: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
@@ -2752,13 +2754,21 @@
(*********************************************************************
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
+ mainWindowSW#misc#set_size_request
+ ~height:((h + 1) * (Prefs.read Uicommon.mainWindowHeight + 1) + 10) ()
+ in
let mainWindow =
- let sw =
- GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:true)
- ~height:(Prefs.read Uicommon.mainWindowHeight * 12)
- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
GList.clist ~columns:5 ~titles_show:true
- ~selection_mode:`MULTIPLE ~packing:sw#add () in
+ ~selection_mode:`MULTIPLE ~packing:mainWindowSW#add ()
+ in
(*
let cols = new GTree.column_list in
let c_replica1 = cols#add Gobject.Data.string in
@@ -2808,7 +2818,8 @@
~title_active:false ~auto_resize:true ~title:data i)
[| " " ^ Unicode.protect (String.sub s 0 12) ^ " "; " Action ";
" " ^ Unicode.protect (String.sub s 15 12) ^ " "; " Status ";
- " Path" |]
+ " Path" |];
+ sizeMainWindow ()
in
setMainWindowColumnHeaders " ";
@@ -3749,6 +3760,7 @@
let loadProfile p reload =
debug (fun()-> Util.msg "Loading profile %s..." p);
+ Trace.status "Loading profile";
Uicommon.initPrefs p
(fun () -> if not reload then displayWaitMessage ())
getFirstRoot getSecondRoot termInteract;
@@ -3787,7 +3799,23 @@
()
end
in
+ let updateCurrent () =
+ let n = mainWindow#rows in
+ (* This has quadratic complexity, thus we only do it when
+ the list is not too long... *)
+ if n < 300 then begin
+ current := IntSet.empty;
+ for i = 0 to n -1 do
+ if mainWindow#get_row_state i = `SELECTED then
+ current := IntSet.add i !current
+ done
+ end
+ in
let doAction f =
+ (* FIX: when the window does not have the focus, we are not notified
+ immediately from changes to the list of selected items. So, we
+ update our view of the current selection here. *)
+ updateCurrent ();
match currentRow () with
Some i ->
doActionOnRow f i;
@@ -3823,12 +3851,10 @@
~callback:leftAction ());
(* actionBar#insert_space ();*)
grAdd grAction
- (actionBar#insert_button
-(* ~icon:((GMisc.pixmap mergeLogoBlack())#coerce)*)
- ~icon:((GMisc.image ~stock:`ADD ())#coerce)
- ~text:"Merge"
- ~tooltip:"Merge selected files"
- ~callback:mergeAction ());
+ (actionBar#insert_button ~text:"Skip"
+ ~icon:((GMisc.image ~stock:`NO ())#coerce)
+ ~tooltip:"Skip selected items"
+ ~callback:questionAction ());
(* actionBar#insert_space ();*)
grAdd grAction
(actionBar#insert_button
@@ -3840,10 +3866,12 @@
~callback:rightAction ());
(* actionBar#insert_space ();*)
grAdd grAction
- (actionBar#insert_button ~text:"Skip"
- ~icon:((GMisc.image ~stock:`NO ())#coerce)
- ~tooltip:"Skip selected items"
- ~callback:questionAction ());
+ (actionBar#insert_button
+(* ~icon:((GMisc.pixmap mergeLogoBlack())#coerce)*)
+ ~icon:((GMisc.image ~stock:`ADD ())#coerce)
+ ~text:"Merge"
+ ~tooltip:"Merge selected files"
+ ~callback:mergeAction ());
(*********************************************************************
Diff / merge buttons
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2010-01-10 22:52:59 UTC (rev 400)
+++ trunk/src/update.ml 2010-01-15 08:29:26 UTC (rev 401)
@@ -1065,10 +1065,11 @@
let immutablenot = Pred.create "immutablenot" ~advanced:true
("This preference overrides {\\tt immutable}.")
-type fastCheckInfos =
+type scanInfo =
{ fastCheck : bool;
dirFastCheck : bool;
- dirStamp : Props.dirChangedStamp }
+ dirStamp : Props.dirChangedStamp;
+ showStatus : bool }
(** Status display **)
@@ -1083,8 +1084,7 @@
finished its own update detection and can receive and acknowledge
the status display message -- thus effectively serializing the client
and server! *)
-let showStatusAddLength info =
- if not !Trace.runningasserver then begin
+let showStatusAddLength scanInfo info =
let len1 = Props.length info.Fileinfo.desc in
let len2 = Osx.ressLength info.Fileinfo.osX.Osx.ressInfo in
if len1 >= bigFileLengthFS || len2 >= bigFileLengthFS then
@@ -1093,21 +1093,18 @@
fileLength :=
min bigFileLength
(!fileLength + Uutil.Filesize.toInt len1 + Uutil.Filesize.toInt len2)
- end
-let showStatus path =
- if not !Trace.runningasserver then begin
+let showStatus scanInfo path =
fileLength := !fileLength + smallFileLength;
if !fileLength >= bigFileLength then begin
fileLength := 0;
let t = Unix.gettimeofday () in
if t -. !t0 > 0.05 then begin
- Uutil.showUpdateStatus (Path.toString path);
-(*Trace.statusDetail ("scanning... " ^ Path.toString path);*)
+ if scanInfo.showStatus then
+ Uutil.showUpdateStatus (Path.toString path);
t0 := t
end
end
- end
let showStatusDir path = ()
@@ -1158,7 +1155,7 @@
(* Check whether the directory contents is different from what is in
the archive *)
let directoryCheckContentUnchanged
- currfspath path info archDesc childUpdates fastCheckInfos =
+ currfspath path info archDesc childUpdates scanInfo =
if
noChildChange childUpdates
&&
@@ -1169,7 +1166,7 @@
let (archDesc, updated) =
let inode =
match Fileinfo.stamp info with Fileinfo.InodeStamp i -> i | _ -> 0 in
- Props.setDirChangeFlag archDesc fastCheckInfos.dirStamp inode in
+ Props.setDirChangeFlag archDesc scanInfo.dirStamp inode in
let updated =
updated || not (Props.same_time info.Fileinfo.desc archDesc) in
if updated then
@@ -1188,12 +1185,12 @@
end
(* Check whether the list of children of a directory is clearly unchanged *)
-let dirContentsClearlyUnchanged info archDesc fastCheckInfos =
- fastCheckInfos.dirFastCheck
+let dirContentsClearlyUnchanged info archDesc scanInfo =
+ scanInfo.dirFastCheck
&&
let inode =
match Fileinfo.stamp info with Fileinfo.InodeStamp i -> i | _ -> 0 in
- Props.dirMarkedUnchanged archDesc fastCheckInfos.dirStamp inode
+ Props.dirMarkedUnchanged archDesc scanInfo.dirStamp inode
&&
Props.same_time info.Fileinfo.desc archDesc
&&
@@ -1222,7 +1219,7 @@
series functions to compute the _old_ archive with updated time stamp
(thus, there will no false update the next time) *)
let checkContentsChange
- currfspath path info archive archDesc archDig archStamp archRess fastCheck
+ currfspath path info archive archDesc archDig archStamp archRess scanInfo
: archive option * Common.updateItem
=
debug (fun () ->
@@ -1242,6 +1239,7 @@
(Uutil.Filesize.toString (Props.length archDesc))
(Uutil.Filesize.toString (Props.length info.Fileinfo.desc));
Util.msg "\n");
+ let fastCheck = scanInfo.fastCheck in
let dataClearlyUnchanged =
Fpcache.dataClearlyUnchanged fastCheck path info archDesc archStamp in
let ressClearlyUnchanged =
@@ -1252,7 +1250,7 @@
None, checkPropChange info.Fileinfo.desc archive archDesc
end else begin
debugverbose (fun() -> Util.msg " Double-check possibly updated file\n");
- showStatusAddLength info;
+ showStatusAddLength scanInfo info;
let (newDesc, newDigest, newStamp, newRess) =
Fpcache.fingerprint fastCheck currfspath path info
(if dataClearlyUnchanged then Some archDig else None) in
@@ -1335,7 +1333,7 @@
remain unchanged, the second a named list of updates; also returns
whether the directory is now empty *)
let rec buildUpdateChildren
- fspath path (archChi: archive NameMap.t) unchangedChildren fastCheckInfos
+ fspath path (archChi: archive NameMap.t) unchangedChildren scanInfo
: archive NameMap.t option * (Name.t * Common.updateItem) list *
bool * bool
=
@@ -1361,9 +1359,9 @@
let archUpdated = ref false in
let handleChild nm archive =
let path' = Path.child path nm in
- showStatus path';
+ showStatus scanInfo path';
let (arch,uiChild) =
- buildUpdateRec archive fspath path' fastCheckInfos in
+ buildUpdateRec archive fspath path' scanInfo in
if uiChild <> NoUpdates then
updates := (nm, uiChild) :: !updates;
match arch with
@@ -1389,7 +1387,7 @@
(Path.toString path'));
archive
end else begin
- showStatus path';
+ showStatus scanInfo path';
match status with
`Ok | `Abs ->
if skip && archive <> NoArchive && status <> `Abs then begin
@@ -1402,7 +1400,7 @@
archive
end else begin
let (arch,uiChild) =
- buildUpdateRec archive fspath path' fastCheckInfos in
+ buildUpdateRec archive fspath path' scanInfo in
if uiChild <> NoUpdates then
updates := (nm, uiChild) :: !updates;
match arch with
@@ -1465,7 +1463,7 @@
((if !archUpdated then Some newChi else None),
Safelist.rev !updates, emptied, !hasIgnoredChildren)
-and buildUpdateRec archive currfspath path fastCheckInfos =
+and buildUpdateRec archive currfspath path scanInfo =
try
debug (fun() ->
Util.msg "buildUpdate: %s\n"
@@ -1482,15 +1480,15 @@
| (`FILE, ArchiveFile (archDesc, archDig, archStamp, archRess)) ->
checkContentsChange
currfspath path info archive
- archDesc archDig archStamp archRess fastCheckInfos.fastCheck
+ archDesc archDig archStamp archRess scanInfo
| (`FILE, _) ->
debug (fun() -> Util.msg " buildUpdate -> Updated file\n");
None,
begin
- showStatusAddLength info;
+ showStatusAddLength scanInfo info;
let (desc, dig, stamp, ress) =
Fpcache.fingerprint
- fastCheckInfos.fastCheck currfspath path info None in
+ scanInfo.fastCheck currfspath path info None in
Xferhint.insertEntry currfspath path dig;
Updates (File (desc, ContentsUpdated (dig, stamp, ress)),
oldInfoOf archive)
@@ -1519,10 +1517,10 @@
else
(PropsUpdated, info.Fileinfo.desc) in
let unchanged =
- dirContentsClearlyUnchanged info archDesc fastCheckInfos in
+ dirContentsClearlyUnchanged info archDesc scanInfo in
let (newChildren, childUpdates, emptied, hasIgnoredChildren) =
buildUpdateChildren
- currfspath path prevChildren unchanged fastCheckInfos in
+ currfspath path prevChildren unchanged scanInfo in
let (archDesc, updated) =
(* If the archive contain ignored children, we cannot use it to
skip reading the directory contents from the filesystem.
@@ -1535,7 +1533,7 @@
ignored and are now ignored.) *)
if hasIgnoredChildren then (archDesc, true) else
directoryCheckContentUnchanged
- currfspath path info archDesc childUpdates fastCheckInfos in
+ currfspath path info archDesc childUpdates scanInfo in
(begin match newChildren with
Some ch ->
Some (ArchiveDir (archDesc, ch))
@@ -1552,7 +1550,7 @@
debug (fun() -> Util.msg " buildUpdate -> New directory\n");
let (newChildren, childUpdates, _, _) =
buildUpdateChildren
- currfspath path NameMap.empty false fastCheckInfos in
+ currfspath path NameMap.empty false scanInfo in
(None,
Updates (Dir (info.Fileinfo.desc, childUpdates, PropsUpdated, false),
oldInfoOf archive))
@@ -1566,12 +1564,12 @@
contents. The directory permissions along the path are also
collected, in case we need to build the directory hierarchy
on one side. *)
-let rec buildUpdate archive fspath fullpath here path dirStamp fastCheckInfos =
+let rec buildUpdate archive fspath fullpath here path dirStamp scanInfo =
match Path.deconstruct path with
None ->
- showStatus here;
+ showStatus scanInfo here;
let (arch, ui) =
- buildUpdateRec archive fspath here fastCheckInfos in
+ buildUpdateRec archive fspath here scanInfo in
(begin match arch with
None -> archive
| Some arch -> arch
@@ -1639,7 +1637,7 @@
let (arch, updates, localPath, props) =
buildUpdate
archChild fspath fullpath (Path.child here name') path'
- dirStamp fastCheckInfos
+ dirStamp scanInfo
in
let children =
if arch = NoArchive then otherChildren else
@@ -1652,7 +1650,7 @@
let (arch, updates, localPath, props) =
buildUpdate
NoArchive fspath fullpath (Path.child here name') path'
- dirStamp fastCheckInfos
+ dirStamp scanInfo
in
assert (arch = NoArchive);
(archive, updates, localPath,
@@ -1718,17 +1716,18 @@
(*
let t1 = Unix.gettimeofday () in
*)
- let fastCheckInfos =
+ let scanInfo =
{ fastCheck = useFastChecking ();
(* Directory optimization is disabled under Windows,
as Windows does not update directory modification times
on FAT filesystems. *)
dirFastCheck = useFastChecking () && Util.osType = `Unix;
- dirStamp = dirStamp }
+ dirStamp = dirStamp;
+ showStatus = not !Trace.runningasserver }
in
let (cacheFilename, _) = archiveName fspath FPCache in
let cacheFile = Os.fileInUnisonDir cacheFilename in
- Fpcache.init fastCheckInfos.fastCheck cacheFile;
+ Fpcache.init scanInfo.fastCheck cacheFile;
let (archive, updates) =
Safelist.fold_right
(fun path (arch, upd) ->
@@ -1737,7 +1736,7 @@
else
let (arch', ui, localPath, props) =
buildUpdate
- arch fspath path Path.empty path dirStamp fastCheckInfos
+ arch fspath path Path.empty path dirStamp scanInfo
in
arch', (localPath, ui, props) :: upd)
pathList (archive, [])
@@ -2173,11 +2172,12 @@
state of the replica... *)
let archive = updateArchiveRec ui archive in
(* ...and check that this is a good description of what's out in the world *)
- let fastCheckInfos =
+ let scanInfo =
{ fastCheck = false; dirFastCheck = false;
- dirStamp = Props.changedDirStamp }
+ dirStamp = Props.changedDirStamp;
+ showStatus = false }
in
- let (_, uiNew) = buildUpdateRec archive fspath localPath fastCheckInfos in
+ let (_, uiNew) = buildUpdateRec archive fspath localPath scanInfo in
markPossiblyUpdatedRec fspath pathInArchive uiNew;
explainUpdate pathInArchive uiNew;
archive
More information about the Unison-hackers
mailing list