[Unison-hackers] [unison-svn] r349 - in trunk/src: . lwt ubase
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Tue Jun 9 04:54:03 EDT 2009
Author: vouillon
Date: 2009-06-09 04:53:55 -0400 (Tue, 09 Jun 2009)
New Revision: 349
Modified:
trunk/src/RECENTNEWS
trunk/src/copy.ml
trunk/src/fileinfo.ml
trunk/src/fileinfo.mli
trunk/src/files.ml
trunk/src/fspath.ml
trunk/src/lwt/lwt_unix.ml
trunk/src/mkProjectInfo.ml
trunk/src/osx.ml
trunk/src/remote.ml
trunk/src/remote.mli
trunk/src/stasher.ml
trunk/src/terminal.ml
trunk/src/ubase/uprintf.ml
trunk/src/uigtk2.ml
trunk/src/update.ml
Log:
* Improvement to the code for resuming directory transfers:
- make sure file information (permissions, ...) has been properly set
when using a previously transferred temp file
- make sure previously transferred directories are writable
* Some cleanup in file transfer implementation
* Got rid of all occurrences of "try ... with _ -> ..."
* Removed ctime field from Fileinfo.t
* Fixed bug in Lwt_unix.run which could make it fail with a Not_found
exception
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/RECENTNEWS 2009-06-09 08:53:55 UTC (rev 349)
@@ -1,5 +1,18 @@
CHANGES FROM VERSION 2.34.0
+* Improvement to the code for resuming directory transfers:
+ - make sure file information (permissions, ...) has been properly set
+ when using a previously transferred temp file
+ - make sure previously transferred directories are writable
+* Some cleanup in file transfer implementation
+* Got rid of all occurrences of "try ... with _ -> ..."
+* Removed ctime field from Fileinfo.t
+* Fixed bug in Lwt_unix.run which could make it fail with a Not_found
+ exception
+
+-------------------------------
+CHANGES FROM VERSION 2.34.0
+
* Fix to the Mac GUI: the bigarray library is now required
-------------------------------
CHANGES FROM VERSION 2.34.0
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/copy.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -22,14 +22,54 @@
(****)
+let protect f g =
+ try
+ f ()
+ with Sys_error _ | Unix.Unix_error _ | Util.Transient _ as e ->
+ begin try g () with Sys_error _ | Unix.Unix_error _ -> () end;
+ raise e
+
+let lwt_protect f g =
+ Lwt.catch f
+ (fun e ->
+ begin match e with
+ Sys_error _ | Unix.Unix_error _ | Util.Transient _ ->
+ begin try g () with Sys_error _ | Unix.Unix_error _ -> () end
+ | _ ->
+ ()
+ end;
+ Lwt.fail e)
+
+(****)
+
+let fileIsTransferred fspathTo pathTo desc fp ress =
+ let info = Fileinfo.get false fspathTo pathTo in
+ (info,
+ info.Fileinfo.typ = `FILE &&
+ Props.length info.Fileinfo.desc = Props.length desc
+ && Osx.ressLength info.Fileinfo.osX.Osx.ressInfo =
+ Osx.ressLength ress
+ &&
+ let fp' = Os.fingerprint fspathTo pathTo info in
+ fp' = fp)
+
+(****)
+
+let removeOldTempFile fspathTo pathTo =
+ if Os.exists fspathTo pathTo then begin
+ debug (fun() -> Util.msg "Removing old temp file %s / %s\n"
+ (Fspath.toDebugString fspathTo) (Path.toString pathTo));
+ Os.delete fspathTo pathTo
+ end
+
let openFileIn fspath path kind =
match kind with
- `DATA -> Fs.open_in_bin (Fspath.concat fspath path)
- | `RESS _ -> Osx.openRessIn fspath path
+ `DATA -> Fs.open_in_bin (Fspath.concat fspath path)
+ | `RESS -> Osx.openRessIn fspath path
-let openFileOut fspath path kind =
+let openFileOut fspath path kind len =
match kind with
- `DATA ->
+ `DATA ->
let fullpath = Fspath.concat fspath path in
let flags = [Unix.O_WRONLY;Unix.O_CREAT] in
let perm = 0o600 in
@@ -50,29 +90,34 @@
in
Unix.out_channel_of_descr fd
end
- | `RESS len ->
+ | `RESS ->
Osx.openRessOut fspath path len
-let protect f g =
- try
- f ()
- with Sys_error _ | Unix.Unix_error _ | Util.Transient _ as e ->
- begin try g () with Sys_error _ | Unix.Unix_error _ -> () end;
- raise e
+let setFileinfo fspathTo pathTo realPathTo update desc =
+ match update with
+ `Update _ -> Fileinfo.set fspathTo pathTo (`Copy realPathTo) desc
+ | `Copy -> Fileinfo.set fspathTo pathTo (`Set Props.fileDefault) desc
-let lwt_protect f g =
- Lwt.catch f
- (fun e ->
- begin match e with
- Sys_error _ | Unix.Unix_error _ | Util.Transient _ ->
- begin try g () with Sys_error _ | Unix.Unix_error _ -> () end
- | _ ->
- ()
- end;
- Lwt.fail e)
-
(****)
+let copyContents fspathFrom pathFrom fspathTo pathTo fileKind fileLength ido =
+ let use_id f = match ido with Some id -> f id | None -> () in
+ let inFd = openFileIn fspathFrom pathFrom fileKind in
+ protect
+ (fun () ->
+ let outFd = openFileOut fspathTo pathTo fileKind fileLength in
+ protect
+ (fun () ->
+ Uutil.readWriteBounded inFd outFd fileLength
+ (fun l ->
+ use_id (fun id ->
+ Abort.check id;
+ Uutil.showProgress id (Uutil.Filesize.ofInt l) "l"));
+ close_in inFd;
+ close_out outFd)
+ (fun () -> close_out_noerr outFd))
+ (fun () -> close_in_noerr inFd)
+
let localFile
fspathFrom pathFrom fspathTo pathTo realPathTo update desc ressLength ido =
let use_id f = match ido with Some id -> f id | None -> () in
@@ -84,43 +129,92 @@
Util.msg "Copy.localFile %s / %s to %s / %s\n"
(Fspath.toDebugString fspathFrom) (Path.toString pathFrom)
(Fspath.toDebugString fspathTo) (Path.toString pathTo));
- let inFd = openFileIn fspathFrom pathFrom `DATA in
- protect (fun () ->
- Os.delete fspathTo pathTo;
- let outFd = openFileOut fspathTo pathTo `DATA in
- protect (fun () ->
- Uutil.readWrite inFd outFd
- (fun l ->
- use_id ( fun id ->
- Abort.check id;
- Uutil.showProgress id (Uutil.Filesize.ofInt l) "l"));
- close_in inFd;
- close_out outFd)
- (fun () -> close_out_noerr outFd))
- (fun () -> close_in_noerr inFd);
- if ressLength > Uutil.Filesize.zero then begin
- let inFd = openFileIn fspathFrom pathFrom (`RESS ressLength) in
- protect (fun () ->
- let outFd = openFileOut fspathTo pathTo (`RESS ressLength) in
- protect (fun () ->
- Uutil.readWriteBounded inFd outFd ressLength
- (fun l ->
- use_id (fun id ->
- Abort.check id;
- Uutil.showProgress id (Uutil.Filesize.ofInt l) "l"));
- close_in inFd;
- close_out outFd)
- (fun () -> close_out_noerr outFd))
- (fun () -> close_in_noerr inFd);
- end;
- match update with
- `Update _ ->
- Fileinfo.set fspathTo pathTo (`Copy realPathTo) desc
- | `Copy ->
- Fileinfo.set fspathTo pathTo (`Set Props.fileDefault) desc)
+ removeOldTempFile fspathTo pathTo;
+ copyContents
+ fspathFrom pathFrom fspathTo pathTo `DATA (Props.length desc) ido;
+ if ressLength > Uutil.Filesize.zero then
+ copyContents
+ fspathFrom pathFrom fspathTo pathTo `RESS ressLength ido;
+ setFileinfo fspathTo pathTo realPathTo update desc)
(****)
+(* BCP '06: This is a hack to work around a bug on the Windows platform
+ that causes lightweight threads on the server to hang. I conjecture that
+ the problem has to do with the RPC mechanism, which was used here to
+ make a call *back* from the server to the client inside Trace.log so that
+ the log message would be appended to the log file on the client. *)
+(* BCP '08: Jerome thinks that printing these messages using Util.msg
+ may be causing the dreaded "assertion failure in remote.ml," which
+ happens only on windows and seems correlated with the xferbycopying
+ switch. The conjecture is that some windows ssh servers may combine
+ the stdout and stderr streams, which would result in these messages
+ getting interleaved with Unison's RPC protocol stream. *)
+let loggit s =
+ if Prefs.read Globals.someHostIsRunningWindows
+ then () (* Util.msg "%s" *)
+ else Trace.log s
+
+let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
+ Prefs.read Xferhint.xferbycopying
+ &&
+ Util.convertUnixErrorsToTransient "tryCopyMovedFile" (fun() ->
+ debug (fun () -> Util.msg "tryCopyMovedFile: -> %s /%s/\n"
+ (Path.toString pathTo) (Os.fullfingerprint_to_string fp));
+ match Xferhint.lookup fp with
+ None ->
+ false
+ | Some (candidateFspath, candidatePath) ->
+ loggit (Printf.sprintf
+ "Shortcut: copying %s from local file %s\n"
+ (Path.toString realPathTo)
+ (Path.toString candidatePath));
+ debug (fun () ->
+ Util.msg
+ "tryCopyMovedFile: found match at %s,%s. Try local copying\n"
+ (Fspath.toDebugString candidateFspath)
+ (Path.toString candidatePath));
+ try
+ if Os.exists candidateFspath candidatePath then begin
+ localFile
+ candidateFspath candidatePath fspathTo pathTo realPathTo
+ update desc (Osx.ressLength ress) (Some id);
+ let (info, isTransferred) =
+ fileIsTransferred fspathTo pathTo desc fp ress in
+ if isTransferred then begin
+ debug (fun () -> Util.msg "tryCopyMoveFile: success.\n");
+ Xferhint.insertEntry (fspathTo, pathTo) fp;
+ true
+ end else begin
+ debug (fun () ->
+ Util.msg "tryCopyMoveFile: candidate file modified!");
+ Xferhint.deleteEntry (candidateFspath, candidatePath);
+ Os.delete fspathTo pathTo;
+ loggit (Printf.sprintf
+ "Shortcut didn't work because %s was modified\n"
+ (Path.toString candidatePath));
+ false
+ end
+ end else begin
+ loggit (Printf.sprintf
+ "Shortcut didn't work because %s disappeared!\n"
+ (Path.toString candidatePath));
+ Xferhint.deleteEntry (candidateFspath, candidatePath);
+ false
+ end
+ with
+ Util.Transient s ->
+ debug (fun () ->
+ Util.msg "tryCopyMovedFile: local copy didn't work [%s]" s);
+ Xferhint.deleteEntry (candidateFspath, candidatePath);
+ Os.delete fspathTo pathTo;
+ loggit (Printf.sprintf
+ "Local copy of %s failed\n"
+ (Path.toString candidatePath));
+ false)
+
+(****)
+
(* The file transfer functions here depend on an external module
'transfer' that implements a generic transmission and the rsync
algorithm for optimizing the file transfer in the case where a
@@ -136,70 +230,8 @@
^ "repeated 'rsync failure' errors, setting it to "
^ "false should permit you to synchronize the offending files.")
-(* Lazy creation of the destination file *)
-let destinationFd fspath path kind outfd =
- match !outfd with
- None ->
- let fd = openFileOut fspath path kind in
- outfd := Some fd;
- fd
- | Some fd ->
- fd
-
let decompressor = ref Remote.MsgIdMap.empty
-let startReceivingFile
- fspath path realPath fileKind update srcFileSize id file_id =
- (* We delay the opening of the file so that there are not too many
- temporary files remaining after a crash *)
- let outfd = ref None in
- let showProgress count =
- Abort.check id;
- Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
- (* Install a simple generic decompressor *)
- decompressor :=
- Remote.MsgIdMap.add file_id
- (fun ti ->
- let fd = destinationFd fspath path fileKind outfd in
- Transfer.receive fd showProgress ti)
- !decompressor;
- if Prefs.read rsyncActivated then begin
- match update with
- `Update (destFileDataSize, destFileRessSize)
- when let destFileSize =
- match fileKind with
- `DATA -> destFileDataSize
- | `RESS _ -> destFileRessSize
- in
- Transfer.Rsync.aboveRsyncThreshold destFileSize
- && Transfer.Rsync.aboveRsyncThreshold srcFileSize ->
- Util.convertUnixErrorsToTransient
- "preprocessing file"
- (fun () ->
- let infd = openFileIn fspath realPath fileKind in
- (* Now that we've successfully opened the original version
- of the file, install a more interesting decompressor *)
- decompressor :=
- Remote.MsgIdMap.add file_id
- (fun ti ->
- let fd = destinationFd fspath path fileKind outfd in
- Transfer.Rsync.rsyncDecompress infd fd showProgress ti)
- !decompressor;
- let bi =
- protect (fun () -> Transfer.Rsync.rsyncPreprocess infd)
- (fun () -> close_in_noerr infd)
- in
- let (firstBi, remBi) =
- match bi with
- [] -> assert false
- | firstBi :: remBi -> (firstBi, remBi)
- in
- Lwt.return (outfd, ref (Some infd), Some firstBi, remBi))
- | _ ->
- Lwt.return (outfd, ref None, None, [])
- end else
- Lwt.return (outfd, ref None, None, [])
-
let processTransferInstruction conn (file_id, ti) =
Util.convertUnixErrorsToTransient
"processing a transfer instruction"
@@ -209,10 +241,11 @@
let marshalTransferInstruction =
(fun (file_id, (data, pos, len)) rem ->
- ((Remote.encodeInt file_id, 0, 4) :: (data, pos, len) :: rem, len + 4)),
+ (Remote.encodeInt file_id :: (data, pos, len) :: rem,
+ len + Remote.intSize)),
(fun buf pos ->
- let len = Bytearray.length buf - pos - 4 in
- (Remote.decodeInt buf pos, (buf, pos + 4, len)))
+ let len = Bytearray.length buf - pos - Remote.intSize in
+ (Remote.decodeInt buf pos, (buf, pos + Remote.intSize, len)))
let processTransferInstructionRemotely =
Remote.registerSpecialServerCmd
@@ -223,38 +256,37 @@
let compress conn
(biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id) =
- Lwt.catch
+ Util.convertUnixErrorsToTransient "rsync sender"
(fun () ->
- let infd = openFileIn fspathFrom pathFrom fileKind in
- lwt_protect (fun () ->
- let showProgress count =
- Abort.check id;
- Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
- let compr =
- match biOpt with
- None -> Transfer.send infd sizeFrom showProgress
- | Some bi -> let remBi =
- try
- Remote.MsgIdMap.find file_id !blockInfos
- with Not_found ->
- []
- in
- let bi = bi :: remBi in
- blockInfos :=
- Remote.MsgIdMap.remove file_id !blockInfos;
- Transfer.Rsync.rsyncCompress
- bi infd sizeFrom showProgress
- in
- compr
- (fun ti -> processTransferInstructionRemotely conn (file_id, ti))
- >>= (fun () ->
- close_in infd;
- Lwt.return ()))
- (fun () ->
- close_in_noerr infd))
- (fun e ->
- Util.convertUnixErrorsToTransient
- "rsync sender" (fun () -> raise e))
+ let infd = openFileIn fspathFrom pathFrom fileKind in
+ lwt_protect
+ (fun () ->
+ let showProgress count =
+ Abort.check id;
+ Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
+ let compr =
+ match biOpt with
+ None -> Transfer.send infd sizeFrom showProgress
+ | Some bi -> let remBi =
+ try
+ Remote.MsgIdMap.find file_id !blockInfos
+ with Not_found ->
+ []
+ in
+ let bi = bi :: remBi in
+ blockInfos :=
+ Remote.MsgIdMap.remove file_id !blockInfos;
+ Transfer.Rsync.rsyncCompress
+ bi infd sizeFrom showProgress
+ in
+ compr
+ (fun ti ->
+ processTransferInstructionRemotely conn (file_id, ti))
+ >>= fun () ->
+ close_in infd;
+ Lwt.return ())
+ (fun () ->
+ close_in_noerr infd))
let compressRemotely = Remote.registerServerCmd "compress" compress
@@ -275,32 +307,6 @@
| x :: r -> sendRemBi conn file_id r >>= (fun () ->
receiveRemBi conn (file_id, x))
-(****)
-
-let fileSize (fspath, path) =
- Util.convertUnixErrorsToTransient
- "getting file size"
- (fun () ->
- Lwt.return
- (Props.length (Fileinfo.get false fspath path).Fileinfo.desc))
-
-let fileSizeOnHost =
- Remote.registerServerCmd "fileSize" (fun _ -> fileSize)
-
-(****)
-
-(* We limit the size of the output buffers to about 512 KB
- (we cannot go above the limit below plus 64) *)
-let transferFileReg = Lwt_util.make_region 440
-
-let bufferSize sz =
- min 64 ((truncate (Uutil.Filesize.toFloat sz) + 1023) / 1024)
- (* Token queue *)
- +
- 8 (* Read buffer *)
-
-(****)
-
let close_all infd outfd =
Util.convertUnixErrorsToTransient
"closing files"
@@ -324,188 +330,147 @@
| None -> ()
end
+(* Lazy creation of the destination file *)
+let destinationFd fspath path kind len outfd =
+ match !outfd with
+ None ->
+ let fd = openFileOut fspath path kind len in
+ outfd := Some fd;
+ fd
+ | Some fd ->
+ fd
+
+let transferFileContents
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update
+ fileKind srcFileSize id =
+ (* We delay the opening of the file so that there are not too many
+ temporary files remaining after a crash *)
+ let outfd = ref None in
+ let infd = ref None in
+ let showProgress count =
+ Abort.check id;
+ Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
+ let (bi, decompr) =
+ match update with
+ `Update (destFileDataSize, destFileRessSize)
+ when Prefs.read rsyncActivated
+ &&
+ let destFileSize =
+ match fileKind with
+ `DATA -> destFileDataSize
+ | `RESS -> destFileRessSize
+ in
+ Transfer.Rsync.aboveRsyncThreshold destFileSize
+ &&
+ Transfer.Rsync.aboveRsyncThreshold srcFileSize ->
+ Util.convertUnixErrorsToTransient
+ "preprocessing file"
+ (fun () ->
+ let ifd = openFileIn fspathTo realPathTo fileKind in
+ let bi =
+ protect (fun () -> Transfer.Rsync.rsyncPreprocess ifd)
+ (fun () -> close_in_noerr ifd)
+ in
+ infd := Some ifd;
+ (bi,
+ (* Rsync decompressor *)
+ fun ti ->
+ let fd =
+ destinationFd
+ fspathTo pathTo fileKind srcFileSize outfd in
+ let eof =
+ Transfer.Rsync.rsyncDecompress ifd fd showProgress ti
+ in
+ if eof then begin close_out fd; outfd := None end))
+ | _ ->
+ ([],
+ (* Simple generic decompressor *)
+ fun ti ->
+ let fd = destinationFd fspathTo pathTo fileKind srcFileSize outfd in
+ let eof = Transfer.receive fd showProgress ti in
+ if eof then begin close_out fd; outfd := None end)
+ in
+ let file_id = Remote.newMsgId () in
+ Lwt.catch
+ (fun () ->
+ decompressor := Remote.MsgIdMap.add file_id decompr !decompressor;
+ Uutil.showProgress id Uutil.Filesize.zero "f";
+ let (firstBi, remBi) =
+ match bi with
+ [] -> (None, [])
+ | firstBi :: remBi -> (Some firstBi, remBi)
+ in
+ sendRemBi connFrom file_id remBi >>= fun () ->
+ compressRemotely connFrom
+ (firstBi, fspathFrom, pathFrom, fileKind, srcFileSize, id, file_id)
+ >>= fun () ->
+ decompressor :=
+ Remote.MsgIdMap.remove file_id !decompressor; (* For GC *)
+ close_all infd outfd;
+ Lwt.return ())
+ (fun e ->
+ decompressor :=
+ Remote.MsgIdMap.remove file_id !decompressor; (* For GC *)
+ close_all_no_error infd outfd;
+ Lwt.fail e)
+
+(****)
+
+let fileSize (fspath, path) =
+ Util.convertUnixErrorsToTransient
+ "getting file size"
+ (fun () ->
+ Lwt.return
+ (Props.length (Fileinfo.get false fspath path).Fileinfo.desc))
+
+let fileSizeOnHost =
+ Remote.registerServerCmd "fileSize" (fun _ -> fileSize)
+
+(****)
+
+let transferRessourceForkAndSetFileinfo
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
+ update desc fp ress id =
+ (* Resource fork *)
+ let ressLength = Osx.ressLength ress in
+ begin if ressLength > Uutil.Filesize.zero then
+ transferFileContents
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update
+ `RESS ressLength id
+ else
+ Lwt.return ()
+ end >>= fun () ->
+ setFileinfo fspathTo pathTo realPathTo update desc;
+ Lwt.return ()
+
(* The ressOnly flag tells reallyTransferFile to skip transferring
the data fork (which has already been taken care of by some external
utility) and just transfer the resource fork (which external utilities
are not necessarily good at). *)
let reallyTransferFile
- connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
- update desc ressLength ressOnly id =
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
+ update desc fp ress ressOnly id =
debug (fun() -> Util.msg "reallyTransferFile(%s,%s) -> (%s,%s,%s,%s)%s\n"
(Fspath.toDebugString fspathFrom) (Path.toString pathFrom)
(Fspath.toDebugString fspathTo) (Path.toString pathTo)
(Path.toString realPathTo) (Props.toString desc)
(if ressOnly then " (ONLY RESOURCE FORK)" else ""));
- let srcFileSize = Props.length desc in
- let file_id = Remote.newMsgId () in
-
- (if ressOnly then
+ (if ressOnly then
(* Skip data fork *)
Lwt.return ()
else begin
- (* Data fork *)
- if Os.exists fspathTo pathTo then begin
- debug (fun() -> Util.msg "Removing old temp file %s / %s\n"
- (Fspath.toDebugString fspathTo) (Path.toString pathTo));
- Os.delete fspathTo pathTo
- end;
- startReceivingFile
- fspathTo pathTo realPathTo `DATA update srcFileSize id file_id
- >>= (fun (outfd, infd, firstBi, remBi) ->
- Lwt.catch (fun () ->
- Uutil.showProgress id Uutil.Filesize.zero "f";
- sendRemBi connFrom file_id remBi >>= (fun () ->
- compressRemotely connFrom
- (firstBi,
- fspathFrom, pathFrom, `DATA, srcFileSize, id, file_id)
- >>= (fun () ->
- decompressor :=
- Remote.MsgIdMap.remove file_id !decompressor; (* For GC *)
- close_all infd outfd;
- Lwt.return ())))
- (* catch handler *)
- (fun e ->
- decompressor :=
- Remote.MsgIdMap.remove file_id !decompressor; (* For GC *)
- close_all_no_error infd outfd;
- Lwt.fail e)
- )end) >>= (fun () ->
+ removeOldTempFile fspathTo pathTo;
+ (* Data fork *)
+ transferFileContents
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update
+ `DATA (Props.length desc) id
+ end) >>= fun () ->
+ transferRessourceForkAndSetFileinfo
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
+ update desc fp ress id
- (* Resource fork *)
- (if ressLength > Uutil.Filesize.zero then begin
- startReceivingFile
- fspathTo pathTo realPathTo
- (`RESS ressLength) update ressLength id file_id
- >>= (fun (outfd, infd, firstBi, remBi) ->
- Lwt.catch (fun () ->
- Uutil.showProgress id Uutil.Filesize.zero "f";
- sendRemBi connFrom file_id remBi >>= (fun () ->
- compressRemotely connFrom
- (firstBi, fspathFrom, pathFrom,
- `RESS ressLength, ressLength, id, file_id)
- >>= (fun () ->
- decompressor :=
- Remote.MsgIdMap.remove file_id !decompressor; (* For GC *)
- close_all infd outfd;
- Lwt.return ())))
- (fun e ->
- decompressor :=
- Remote.MsgIdMap.remove file_id !decompressor; (* For GC *)
- close_all_no_error infd outfd;
- Lwt.fail e))
- end else
- Lwt.return ()) >>= (fun () ->
- begin match update with
- `Update _ -> Fileinfo.set fspathTo pathTo (`Copy realPathTo) desc
- | `Copy -> Fileinfo.set fspathTo pathTo (`Set Props.fileDefault) desc
- end;
- Lwt.return ()))
-
(****)
-(* BCP '06: This is a hack to work around a bug on the Windows platform
- that causes lightweight threads on the server to hang. I conjecture that
- the problem has to do with the RPC mechanism, which was used here to
- make a call *back* from the server to the client inside Trace.log so that
- the log message would be appended to the log file on the client. *)
-(* BCP '08: Jerome thinks that printing these messages using Util.msg
- may be causing the dreaded "assertion failure in remote.ml," which
- happens only on windows and seems correlated with the xferbycopying
- switch. The conjecture is that some windows ssh servers may combine
- the stdout and stderr streams, which would result in these messages
- getting interleaved with Unison's RPC protocol stream. *)
-let loggit s =
- if Prefs.read Globals.someHostIsRunningWindows
- then () (* Util.msg "%s" *)
- else Trace.log s
-
-let tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id =
- Prefs.read Xferhint.xferbycopying
- &&
- begin
- Util.convertUnixErrorsToTransient "tryCopyMovedFile" (fun() ->
- debug (fun () -> Util.msg "tryCopyMovedFile: -> %s /%s/\n"
- (Path.toString pathTo) (Os.fullfingerprint_to_string fp));
- match Xferhint.lookup fp with
- None ->
- false
- | Some (candidateFspath, candidatePath) ->
- loggit (Printf.sprintf
- "Shortcut: copying %s from local file %s\n"
- (Path.toString realPathTo)
- (Path.toString candidatePath));
- debug (fun () ->
- Util.msg
- "tryCopyMovedFile: found match at %s,%s. Try local copying\n"
- (Fspath.toDebugString candidateFspath)
- (Path.toString candidatePath));
- try
- if Os.exists candidateFspath candidatePath then begin
- localFile
- candidateFspath candidatePath fspathTo pathTo realPathTo
- update desc (Osx.ressLength ress) (Some id);
- let info = Fileinfo.get false fspathTo pathTo in
- let fp' = Os.fingerprint fspathTo pathTo info in
- if fp' = fp then begin
- debug (fun () -> Util.msg "tryCopyMoveFile: success.\n");
- Xferhint.insertEntry (fspathTo, pathTo) fp;
- true
- end else begin
- debug (fun () ->
- Util.msg "tryCopyMoveFile: candidate file modified!");
- Xferhint.deleteEntry (candidateFspath, candidatePath);
- Os.delete fspathTo pathTo;
- loggit (Printf.sprintf
- "Shortcut didn't work because %s was modified\n"
- (Path.toString candidatePath));
- false
- end
- end else begin
- loggit (Printf.sprintf
- "Shortcut didn't work because %s disappeared!\n"
- (Path.toString candidatePath));
- Xferhint.deleteEntry (candidateFspath, candidatePath);
- false
- end
- with
- Util.Transient s ->
- debug (fun () ->
- Util.msg "tryCopyMovedFile: local copy didn't work [%s]" s);
- Xferhint.deleteEntry (candidateFspath, candidatePath);
- Os.delete fspathTo pathTo;
- loggit (Printf.sprintf
- "Local copy of %s failed\n"
- (Path.toString candidatePath));
- false)
- end
-
-let transferFileLocal connFrom
- (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
- update, desc, fp, ress, ressOnly, id) =
- if (not ressOnly)
- && tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
- then Lwt.return ()
- else reallyTransferFile
- connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
- update desc (Osx.ressLength ress) ressOnly id
-
-let transferFileOnRoot =
- Remote.registerRootCmdWithConnection "transferFile" transferFileLocal
-
-let transferFile
- rootFrom pathFrom rootTo fspathTo pathTo realPathTo
- update desc fp ress ressOnly id =
- let bufSz = bufferSize (max (Props.length desc) (Osx.ressLength ress)) in
- (* This must be on the client: any lock on the server side may result
- in a deadlock under windows *)
- Lwt_util.run_in_region transferFileReg bufSz (fun () ->
- Abort.check id;
- transferFileOnRoot rootTo rootFrom
- (snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo,
- update, desc, fp, ress, ressOnly, id))
-
-(****)
-
let copyprog =
Prefs.createString "copyprog" "rsync --inplace --compress"
"!external program for copying large files"
@@ -604,6 +569,16 @@
h ^ ":"
| Clroot.ConnectLocal _ -> assert false
+let shouldUseExternalCopyprog update desc =
+ Prefs.read copyprog <> ""
+ && Prefs.read copythreshold >= 0
+ && Props.length desc >= Uutil.Filesize.ofInt64 (Int64.of_int 1)
+ && Props.length desc >=
+ Uutil.Filesize.ofInt64
+ (Int64.mul (Int64.of_int 1000)
+ (Int64.of_int (Prefs.read copythreshold)))
+ && update = `Copy
+
let transferFileUsingExternalCopyprog
rootFrom pathFrom rootTo fspathTo pathTo realPathTo
update desc fp ress id =
@@ -655,6 +630,45 @@
Lwt.return ()))
end)
+(****)
+
+(* We limit the size of the output buffers to about 512 KB
+ (we cannot go above the limit below plus 64) *)
+let transferFileReg = Lwt_util.make_region 440
+
+let bufferSize sz =
+ min 64 ((truncate (Uutil.Filesize.toFloat sz) + 1023) / 1024)
+ (* Token queue *)
+ +
+ 8 (* Read buffer *)
+
+let transferFileLocal connFrom
+ (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
+ update, desc, fp, ress, ressOnly, id) =
+ if (not ressOnly)
+ && tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
+ then Lwt.return ()
+ else reallyTransferFile
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
+ update desc fp ress ressOnly id
+
+let transferFileOnRoot =
+ Remote.registerRootCmdWithConnection "transferFile" transferFileLocal
+
+let transferFile
+ rootFrom pathFrom rootTo fspathTo pathTo realPathTo
+ update desc fp ress ressOnly id =
+ let bufSz = bufferSize (max (Props.length desc) (Osx.ressLength ress)) in
+ (* This must be on the client: any lock on the server side may result
+ in a deadlock under windows *)
+ Lwt_util.run_in_region transferFileReg bufSz (fun () ->
+ Abort.check id;
+ transferFileOnRoot rootTo rootFrom
+ (snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo,
+ update, desc, fp, ress, ressOnly, id))
+
+(****)
+
let file rootFrom pathFrom rootTo fspathTo pathTo realPathTo
update desc fp ress id =
debug (fun() -> Util.msg "copyRegFile(%s,%s) -> (%s,%s,%s,%s,%s)\n"
@@ -678,19 +692,11 @@
Trace.log (Printf.sprintf
"%s/%s has already been transferred\n"
(Fspath.toDebugString fspathTo) (Path.toString pathTo));
- Lwt.return ()
+ (* Make sure the file information is right *)
+ setFileinfoOnRoot rootTo rootFrom (fspathTo, pathTo, desc)
(* Check whether we should use an external program to copy the
file *)
- end else if
- Prefs.read copyprog <> ""
- && Prefs.read copythreshold >= 0
- && Props.length desc >= Uutil.Filesize.ofInt64 (Int64.of_int 1)
- && Props.length desc >=
- Uutil.Filesize.ofInt64
- (Int64.mul (Int64.of_int 1000)
- (Int64.of_int (Prefs.read copythreshold)))
- && update = `Copy
- then begin
+ end else if shouldUseExternalCopyprog update desc then begin
(* First use the external program to copy the data fork *)
transferFileUsingExternalCopyprog
rootFrom pathFrom rootTo fspathTo pathTo realPathTo
Modified: trunk/src/fileinfo.ml
===================================================================
--- trunk/src/fileinfo.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/fileinfo.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -26,8 +26,7 @@
| `DIRECTORY -> "dir"
| `SYMLINK -> "symlink"
-type t = { typ : typ; inode : int; ctime : float;
- desc : Props.t; osX : Osx.info}
+type t = { typ : typ; inode : int; desc : Props.t; osX : Osx.info}
(* Stat function that pays attention to pref for following links *)
let statFn fromRoot fspath path =
@@ -71,14 +70,12 @@
inode = (* The inode number is truncated so that
it fits in a 31 bit ocaml integer *)
stats.Unix.LargeFile.st_ino land 0x3FFFFFFF;
- ctime = stats.Unix.LargeFile.st_ctime;
desc = Props.get stats osxInfos;
osX = osxInfos }
with
Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) ->
{ typ = `ABSENT;
inode = 0;
- ctime = 0.0;
desc = Props.dummy;
osX = Osx.getFileInfos fspath path `ABSENT })
@@ -175,13 +172,11 @@
let osxInfos = Osx.defaultInfos typ in
{ typ = typ;
inode = stats.Unix.LargeFile.st_ino land 0x3FFFFFFF;
- ctime = stats.Unix.LargeFile.st_ctime;
desc = Props.get stats osxInfos;
osX = osxInfos }
with
Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) ->
{ typ = `ABSENT;
inode = 0;
- ctime = 0.0;
desc = Props.dummy;
osX = Osx.defaultInfos `ABSENT })
Modified: trunk/src/fileinfo.mli
===================================================================
--- trunk/src/fileinfo.mli 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/fileinfo.mli 2009-06-09 08:53:55 UTC (rev 349)
@@ -4,8 +4,7 @@
type typ = [`ABSENT | `FILE | `DIRECTORY | `SYMLINK]
val type2string : typ -> string
-type t = { typ : typ; inode : int; ctime : float;
- desc : Props.t; osX : Osx.info}
+type t = { typ : typ; inode : int; desc : Props.t; osX : Osx.info}
val get : bool -> Fspath.t -> Path.local -> t
val set : Fspath.t -> Path.local ->
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/files.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -139,23 +139,28 @@
setPropRemote2 toRoot (toLocalPath, `Update oldDesc, newDesc))))
(* ------------------------------------------------------------ *)
-
+
let mkdirRemote =
Remote.registerRootCmd
"mkdir"
(fun (fspath,(workingDir,path)) ->
- let createIt() = Os.createDir workingDir path Props.dirDefault in
- if Os.exists workingDir path then
- if (Fileinfo.get false workingDir path).Fileinfo.typ <> `DIRECTORY then begin
+ let info = Fileinfo.get false workingDir path in
+ if info.Fileinfo.typ = `DIRECTORY then begin
+ begin try
+ (* Make sure the directory is writable *)
+ Fs.chmod (Fspath.concat workingDir path)
+ (Props.perms info.Fileinfo.desc lor 0o700)
+ with Unix.Unix_error _ -> () end;
+ Lwt.return info.Fileinfo.desc
+ end else begin
+ if info.Fileinfo.typ <> `ABSENT then
Os.delete workingDir path;
- createIt()
- end else ()
- else
- createIt();
- Lwt.return (Fileinfo.get false workingDir path).Fileinfo.desc)
-
+ Os.createDir workingDir path Props.dirDefault;
+ Lwt.return (Fileinfo.get false workingDir path).Fileinfo.desc
+ end)
+
let mkdir onRoot workingDir path = mkdirRemote onRoot (workingDir,path)
-
+
(* ------------------------------------------------------------ *)
let renameLocal (root, (localTargetPath, fspath, pathFrom, pathTo)) =
@@ -362,7 +367,7 @@
(root2string rootTo) (Path.toString pathTo));
(* Calculate target paths *)
setupTargetPaths rootTo pathTo
- >>= (fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
+ >>= fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
(* Inner loop for recursive copy... *)
let rec copyRec pFrom (* Path to copy from *)
pTo (* (Temp) path to copy to *)
@@ -449,19 +454,17 @@
the changes yet) and return the part of the new archive
corresponding to this path *)
Update.updateArchive rootFrom pathFrom uiFrom id
- >>= (fun (localPathFrom, archFrom) ->
+ >>= fun (localPathFrom, archFrom) ->
let make_backup =
(* Perform (asynchronously) a backup of the destination files *)
Update.updateArchive rootTo pathTo uiTo id
in
- copyRec localPathFrom tempPathTo realPathTo archFrom >>= (fun () ->
- make_backup >>= (fun _ ->
+ copyRec localPathFrom tempPathTo realPathTo archFrom >>= fun () ->
+ make_backup >>= fun _ ->
Update.replaceArchive
rootTo pathTo (Some (workingDir, tempPathTo))
- archFrom id true true >>= (fun _ ->
- rename rootTo pathTo localPathTo workingDir tempPathTo realPathTo uiTo >>= (fun() ->
- debug (fun() -> Util.msg "Removing temp files\n");
- performDelete rootTo (Some workingDir, tempPathTo) )))))))
+ archFrom id true true >>= fun _ ->
+ rename rootTo pathTo localPathTo workingDir tempPathTo realPathTo uiTo)
(* ------------------------------------------------------------ *)
Modified: trunk/src/fspath.ml
===================================================================
--- trunk/src/fspath.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/fspath.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -76,7 +76,7 @@
try
let n' = String.rindex_from f (len-n) '/' in
String.sub f (n'+1) (len-n'-1)
- with _ -> f in
+ with Not_found -> f in
let s1 = suffix f1 len1 in
let s2 = suffix f2 len2 in
(s1,s2)
Modified: trunk/src/lwt/lwt_unix.ml
===================================================================
--- trunk/src/lwt/lwt_unix.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/lwt/lwt_unix.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -141,33 +141,39 @@
restart_threads !event_counter now;
List.iter
(fun fd ->
- match List.assoc fd !inputs with
- `Read (buf, pos, len, res) ->
- wrap_syscall inputs fd res
- (fun () -> Unix.read fd buf pos len)
- | `Accept res ->
- wrap_syscall inputs fd res
- (fun () ->
- let (s, _) as v = Unix.accept fd in
- if not windows_hack then Unix.set_nonblock s;
- v)
- | `Wait res ->
- wrap_syscall inputs fd res (fun () -> ()))
+ try
+ match List.assoc fd !inputs with
+ `Read (buf, pos, len, res) ->
+ wrap_syscall inputs fd res
+ (fun () -> Unix.read fd buf pos len)
+ | `Accept res ->
+ wrap_syscall inputs fd res
+ (fun () ->
+ let (s, _) as v = Unix.accept fd in
+ if not windows_hack then Unix.set_nonblock s;
+ v)
+ | `Wait res ->
+ wrap_syscall inputs fd res (fun () -> ())
+ with Not_found ->
+ ())
readers;
List.iter
(fun fd ->
- match List.assoc fd !outputs with
- `Write (buf, pos, len, res) ->
- wrap_syscall outputs fd res
- (fun () -> Unix.write fd buf pos len)
- | `CheckSocket res ->
- wrap_syscall outputs fd res
- (fun () ->
- try ignore (Unix.getpeername fd) with
- Unix.Unix_error (Unix.ENOTCONN, _, _) ->
- ignore (Unix.read fd " " 0 1))
- | `Wait res ->
- wrap_syscall inputs fd res (fun () -> ()))
+ try
+ match List.assoc fd !outputs with
+ `Write (buf, pos, len, res) ->
+ wrap_syscall outputs fd res
+ (fun () -> Unix.write fd buf pos len)
+ | `CheckSocket res ->
+ wrap_syscall outputs fd res
+ (fun () ->
+ try ignore (Unix.getpeername fd) with
+ Unix.Unix_error (Unix.ENOTCONN, _, _) ->
+ ignore (Unix.read fd " " 0 1))
+ | `Wait res ->
+ wrap_syscall inputs fd res (fun () -> ())
+ with Not_found ->
+ ())
writers;
if !child_exited then begin
child_exited := false;
@@ -208,6 +214,8 @@
let write ch buf pos len =
try
+ if windows_hack && recent_ocaml then
+ raise (Unix.Unix_error (Unix.EAGAIN, "", ""));
Lwt.return (Unix.write ch buf pos len)
with
Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
@@ -284,11 +292,7 @@
let system cmd =
match Unix.fork () with
- 0 -> begin try
- Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
- with _ ->
- exit 127
- end
+ 0 -> Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
| id -> Lwt.bind (waitpid [] id) (fun (pid, status) -> Lwt.return status)
(****)
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/mkProjectInfo.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -158,3 +158,4 @@
+
Modified: trunk/src/osx.ml
===================================================================
--- trunk/src/osx.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/osx.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -110,6 +110,7 @@
raise e
let openDouble fspath path =
+ let (fspath, path) = Fspath.findWorkingDir fspath path in
let path = Fspath.appleDouble (Fspath.concat fspath path) in
let inch = try Fs.open_in_bin path with Sys_error _ -> raise Not_found in
protect (fun () ->
@@ -212,7 +213,6 @@
with Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOSYS), _, _) ->
(* Not a HFS volume. Look for an AppleDouble file *)
try
- let (fspath, path) = Fspath.findWorkingDir fspath path in
let (doublePath, inch, entries) = openDouble fspath path in
let (rsrcOffset, rsrcLength) =
try Safelist.assoc `RSRC entries with Not_found ->
@@ -281,7 +281,6 @@
setFileInfosInternal p (insertInfo fullFinfo finfo)
with Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOSYS), _, _) ->
(* Not an HFS volume. Look for an AppleDouble file *)
- let (fspath, path) = Fspath.findWorkingDir fspath path in
begin try
let (doublePath, inch, entries) = openDouble fspath path in
begin try
Modified: trunk/src/remote.ml
===================================================================
--- trunk/src/remote.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/remote.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -18,7 +18,7 @@
let (>>=) = Lwt.bind
let debug = Trace.debug "remote"
-let debugV = Trace.debug "remote+"
+let debugV = Trace.debug "remote_emit+"
let debugE = Trace.debug "remote+"
let debugT = Trace.debug "remote+"
@@ -29,16 +29,21 @@
*)
let windowsHack = Sys.os_type <> "Unix"
+let recent_ocaml =
+ Scanf.sscanf Sys.ocaml_version "%d.%d"
+ (fun maj min -> (maj = 3 && min >= 11) || maj > 3)
(****)
+let intSize = 4
+
let encodeInt m =
- let int_buf = Bytearray.create 4 in
+ let int_buf = Bytearray.create intSize in
int_buf.{0} <- Char.chr ( m land 0xff);
int_buf.{1} <- Char.chr ((m lsr 8) land 0xff);
int_buf.{2} <- Char.chr ((m lsr 16) land 0xff);
int_buf.{3} <- Char.chr ((m lsr 24) land 0xff);
- int_buf
+ (int_buf, 0, intSize)
let decodeInt int_buf i =
let b0 = Char.code (int_buf.{i + 0}) in
@@ -198,7 +203,7 @@
conn.canWrite <- false;
debugE (fun() -> Util.msg "Sending write token\n");
(* Special message allowing the other side to write *)
- fill_buffer conn [(encodeInt 0, 0, 4)] >>= (fun () ->
+ fill_buffer conn [encodeInt 0] >>= (fun () ->
flush_buffer conn) >>= (fun () ->
if windowsHack then begin
debugE (fun() -> Util.msg "Restarting reader\n");
@@ -218,11 +223,6 @@
Lwt.return ()
end
-let rec msg_length l =
- match l with
- [] -> 0
- | (s, p, l)::r -> l + msg_length r
-
(* Send all pending messages *)
let rec dump_rec conn =
try
@@ -350,22 +350,8 @@
else
Bytearray.sub s p len
-(* An integer just a little smaller than the maximum representable in 30 bits *)
-let hugeint = 1000000000
-
let safeMarshal marshalPayload tag data rem =
let (rem', length) = marshalPayload data rem in
- if length > hugeint then begin
- let start = first_chars (min length 10) rem' in
- let start = if length > 10 then start ^ "..." else start in
- let start = String.escaped start in
- Util.msg "Fatal error in safeMarshal: sending too many (%d) bytes with tag %s and contents [%s]\n" length (Bytearray.to_string tag) start;
- raise (Util.Fatal ((Printf.sprintf
- "Message payload too large (%d, %s, [%s]). \n"
- length (Bytearray.to_string tag) start)
- ^ "This is a bug in Unison; if it happens to you in a repeatable way, \n"
- ^ "please post a report on the unison-users mailing list."))
- end;
let l = Bytearray.length tag in
debugE (fun() ->
let start = first_chars (min length 10) rem' in
@@ -373,7 +359,7 @@
let start = String.escaped start in
Util.msg "send [%s] '%s' %d bytes\n"
(Bytearray.to_string tag) start length);
- ((encodeInt (l + length), 0, 4) :: (tag, 0, l) :: rem')
+ (encodeInt (l + length) :: (tag, 0, l) :: rem')
let safeUnmarshal unmarshalPayload tag buf =
let taglength = Bytearray.length tag in
@@ -526,8 +512,8 @@
let receivePacket conn =
(* Get the length of the packet *)
- let int_buf = Bytearray.create 4 in
- grab conn int_buf 4 >>= (fun () ->
+ let int_buf = Bytearray.create intSize in
+ grab conn int_buf intSize >>= (fun () ->
let length = decodeInt int_buf 0 in
assert (length >= 0);
(* Get packet *)
@@ -563,22 +549,25 @@
Lwt.try_bind (fun () -> cmd conn buf)
(fun marshal ->
debugE (fun () -> Util.msg "Sending result (id: %d)\n" (decodeInt id 0));
- dump conn ((id, 0, 4) :: marshalHeader NormalResult (marshal [])))
+ dump conn ((id, 0, intSize) :: marshalHeader NormalResult (marshal [])))
(function
Util.Transient s ->
debugE (fun () ->
Util.msg "Sending transient exception (id: %d)\n" (decodeInt id 0));
- dump conn ((id, 0, 4) :: marshalHeader (TransientExn s) [])
+ dump conn ((id, 0, intSize) :: marshalHeader (TransientExn s) [])
| Util.Fatal s ->
debugE (fun () ->
Util.msg "Sending fatal exception (id: %d)\n" (decodeInt id 0));
- dump conn ((id, 0, 4) :: marshalHeader (FatalExn s) [])
+ dump conn ((id, 0, intSize) :: marshalHeader (FatalExn s) [])
| e ->
Lwt.fail e)
(* Message ids *)
type msgId = int
module MsgIdMap = Map.Make (struct type t = msgId let compare = compare end)
+(* An integer just a little smaller than the maximum representable in
+ 30 bits *)
+let hugeint = 1000000000
let ids = ref 1
let newMsgId () = incr ids; if !ids = hugeint then ids := 2; !ids
@@ -593,7 +582,7 @@
(* Receiving thread: read a message and dispatch it to the right
thread or create a new thread to process requests. *)
let rec receive conn =
- (if windowsHack && conn.canWrite then
+ (if windowsHack && conn.canWrite && not recent_ocaml then
let wait = Lwt.wait () in
assert (conn.reader = None);
conn.reader <- Some wait;
@@ -602,8 +591,8 @@
Lwt.return ()) >>= (fun () ->
debugE (fun () -> Util.msg "Waiting for next message\n");
(* Get the message ID *)
- let id = Bytearray.create 4 in
- grab conn id 4 >>= (fun () ->
+ let id = Bytearray.create intSize in
+ grab conn id intSize >>= (fun () ->
let num_id = decodeInt id 0 in
if num_id = 0 then begin
debugE (fun () -> Util.msg "Received the write permission\n");
@@ -679,7 +668,7 @@
let id = newMsgId () in (* Message ID *)
assert (id >= 0); (* tracking down an assert failure in receivePacket... *)
let request =
- (encodeInt id, 0, 4) ::
+ encodeInt id ::
marshalHeader (Request cmdName) (marshalArgs serverArgs [])
in
let reply = wait_for_reply id in
@@ -1113,12 +1102,13 @@
Lwt.return ())
let openConnectionCancel (i1,i2,o1,o2,s,fdopt,clroot,pid) =
- try Unix.kill pid Sys.sigkill with _ -> ();
- try Unix.close i1 with _ -> ();
- try Unix.close i2 with _ -> ();
- try Unix.close o1 with _ -> ();
- try Unix.close o2 with _ -> ();
- match fdopt with None -> () | Some fd -> (try Unix.close fd with _ -> ())
+ 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 Unix.close o2 with Unix.Unix_error _ -> ();
+ match fdopt with
+ None -> () | Some fd -> (try Unix.close fd with Unix.Unix_error _ -> ())
(****************************************************************************)
(* SERVER-MODE COMMAND PROCESSING LOOP *)
Modified: trunk/src/remote.mli
===================================================================
--- trunk/src/remote.mli 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/remote.mli 2009-06-09 08:53:55 UTC (rev 349)
@@ -94,7 +94,8 @@
('a ->
(Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
(Bytearray.t -> int -> 'b)
-val encodeInt : int -> Bytearray.t
+val intSize : int
+val encodeInt : int -> Bytearray.t * int * int
val decodeInt : Bytearray.t -> int -> int
val registerRootCmdWithConnection :
string (* command name *)
Modified: trunk/src/stasher.ml
===================================================================
--- trunk/src/stasher.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/stasher.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -329,7 +329,7 @@
let path0 = makeBackupName path 0 in
let sourceTyp = (Fileinfo.get true fspath path).Fileinfo.typ in
- let path0Typ = (Fileinfo.get true sFspath path0).Fileinfo.typ in
+ let path0Typ = (Fileinfo.get false sFspath path0).Fileinfo.typ in
if ( sourceTyp = `FILE && path0Typ = `FILE
&& (Fingerprint.file fspath path) = (Fingerprint.file sFspath path0))
@@ -408,13 +408,13 @@
debug (fun () -> Util.msg " Finished copying; deleting %s / %s\n"
(Fspath.toDebugString fspath) (Path.toString path));
disposeIfNeeded() in
- try
- if finalDisposition = `AndRemove then
+ if finalDisposition = `AndRemove then
+ try
Os.rename "backup" fspath path backRoot backPath
- else
+ with Util.Transient _ ->
+ debug (fun () -> Util.msg "Rename failed -- copying instead\n");
byCopying()
- with _ ->
- debug (fun () -> Util.msg "Rename failed -- copying instead\n");
+ else
byCopying()
end else begin
debug (fun () -> Util.msg "Path %s / %s does not need to be backed up\n"
Modified: trunk/src/terminal.ml
===================================================================
--- trunk/src/terminal.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/terminal.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -77,7 +77,7 @@
x.[9] <- a2.(j);
let fdOpt =
try Some(Unix.openfile x [Unix.O_RDWR] 0)
- with _ -> None in
+ with Unix.Unix_error _ -> None in
match fdOpt with None -> ()
| Some fdMaster ->
x.[5] <- 't';
@@ -92,7 +92,7 @@
| Some(fdMaster,ttySlave) ->
let slave =
try Some (Unix.openfile ttySlave [Unix.O_RDWR] 0o600)
- with _ -> None in
+ with Unix.Unix_error _ -> None in
(try Unix.close fdMaster with Unix.Unix_error(_,_,_) -> ());
slave
@@ -202,7 +202,7 @@
Unix.tcsetattr slaveFd Unix.TCSANOW tio;
perform_redirections new_stdin new_stdout new_stderr;
Unix.execvp cmd args (* never returns *)
- with _ ->
+ with Unix.Unix_error _ ->
Printf.eprintf "Some error in create_session child\n";
flush stderr;
exit 127
Modified: trunk/src/ubase/uprintf.ml
===================================================================
--- trunk/src/ubase/uprintf.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/ubase/uprintf.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -37,7 +37,7 @@
let p =
try
int_of_string (String.sub format (i+1) (j-i-1))
- with _ ->
+ with Failure _ ->
invalid_arg "fprintf: bad %s format" in
if p > 0 && String.length s < p then begin
output_string outchan
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/uigtk2.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -1976,6 +1976,7 @@
let detectCmdName = "Restart" in
let detectCmd () =
getLock detectUpdatesAndReconcile;
+ updateDetails ();
if Prefs.read Globals.batch then begin
Prefs.set Globals.batch false; synchronize()
end
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-05-29 17:14:48 UTC (rev 348)
+++ trunk/src/update.ml 2009-06-09 08:53:55 UTC (rev 349)
@@ -626,7 +626,7 @@
(* commitActions(thisRoot, id) <- action *)
let setCommitAction (thisRoot: string) (id: int) (action: unit -> unit): unit =
let key = (thisRoot, id) in
- Hashtbl.add commitActions key action
+ Hashtbl.replace commitActions key action
(* perform and remove the action associated with (thisRoot, id) *)
let softCommitLocal (thisRoot: string) (id: int) =
@@ -1165,8 +1165,7 @@
(Util.msg "archStamp is inode (%d)" inode;
Util.msg " / info.inode (%d)" info.Fileinfo.inode)
| Fileinfo.CtimeStamp stamp ->
- (Util.msg "archStamp is ctime (%f)" stamp;
- Util.msg " / info.ctime (%f)" info.Fileinfo.ctime)
+ (Util.msg "archStamp is ctime (%f)" stamp)
end;
Util.msg " / times: %f = %f... %b"
(Props.time archDesc) (Props.time info.Fileinfo.desc)
@@ -1627,10 +1626,6 @@
let findUpdates () : Common.updateItem list Common.oneperpath =
(* TODO: We should filter the paths to remove duplicates (including prefixes)
and ignored paths *)
-(* FIX: The following line can be deleted -- it's just for debugging *)
-debug (fun() -> Util.msg "Running bogus external program\n");
-let _ = External.runExternalProgram "dir" in
-debug (fun() -> Util.msg "Finished running bogus external program\n");
findUpdatesOnPaths (Prefs.read Globals.paths)
More information about the Unison-hackers
mailing list