[Unison-hackers] [unison-svn] r378 - in trunk/src: . ubase
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Sun Jul 19 16:07:54 EDT 2009
Author: vouillon
Date: 2009-07-19 16:07:54 -0400 (Sun, 19 Jul 2009)
New Revision: 378
Modified:
trunk/src/RECENTNEWS
trunk/src/common.ml
trunk/src/common.mli
trunk/src/copy.ml
trunk/src/fileinfo.ml
trunk/src/fileinfo.mli
trunk/src/files.ml
trunk/src/files.mli
trunk/src/globals.ml
trunk/src/mkProjectInfo.ml
trunk/src/path.ml
trunk/src/path.mli
trunk/src/props.ml
trunk/src/recon.ml
trunk/src/recon.mli
trunk/src/remote.ml
trunk/src/remote.mli
trunk/src/transfer.ml
trunk/src/transfer.mli
trunk/src/transport.ml
trunk/src/ubase/prefs.ml
trunk/src/ubase/prefs.mli
trunk/src/uicommon.ml
trunk/src/uigtk2.ml
trunk/src/uimacbridge.ml
trunk/src/uitext.ml
trunk/src/update.ml
trunk/src/update.mli
Log:
* Bumped version number: incompatible protocol changes
* Create parent directories (with correct permissions) during
transport for paths which point to non-existent locations in the
destination replica.
* Keep track of which file contents are being transferred, and delay
the transfer of a file when another file with the same contents is
currently being transferred. This way, the second transfer can be
skipped and replaced by a local copy.
* Changes to the implementation of the rsync algorithm:
- use longer blocks for large files (the size of a block is the
square root of the size of the file for large files);
- transmit less checksum information per block (we still have less
than one chance in a hundred million of transferring a file
incorrectly, and Unison will catch any transfer error when
fingerprinting the whole file)
- avoid transfer overhead (which was 4 bytes per block)
For a 1G file, the first optimization saves a factor 50 on the
amount of data transferred from the target to the source (blocks
are 32768 bytes rather than just 700 bytes). The two other
optimizations save another factor of 2 (from 24 bytes per block
down to 10).
* New "links" preference. When set to false, Unison will report an
error on symlinks during update detection. (This is the default
when one host is running Windows but not Cygwin.) This is better
than failing during propagation.
* Added a preference "halfduplex" to force half-duplex communication
with the server. This may be useful on unreliable links (as a more
efficient alternative to "maxthreads = 1").
* Renamed preference "pretendwin" to "ignoreinodenumbers" (an alias is
kept for backwards compatibility).
* GTK UI: display estimated remaining time and transfer rate on the
progress bar
* GTK UI: some polishing; in particular:
- stop statistics window updates when idle (save power on laptops)
- some ok and cancel buttons were in the wrong order
* Added some support for making it easier to extend Unison without
breaking backwards compatibility.
- Possibility to mark a preference as local. Such a preference is
propagated if possible but will not result in an error if it is
not found server-side. This make it possible to add new
functionalities client-side without breaking compatibility.
- Added a function [Remove.commandAvailable] which tests whether a
command is available on a given root.
* Removed hack in findUpdates that would update the archive in a
visible way for the sake of path translation: it is no longer
needed.
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/RECENTNEWS 2009-07-19 20:07:54 UTC (rev 378)
@@ -1,3 +1,56 @@
+CHANGES FROM VERSION 2.37.1
+
+* Bumped version number: incompatible protocol changes
+
+* Create parent directories (with correct permissions) during
+ transport for paths which point to non-existent locations in the
+ destination replica.
+* Keep track of which file contents are being transferred, and delay
+ the transfer of a file when another file with the same contents is
+ currently being transferred. This way, the second transfer can be
+ skipped and replaced by a local copy.
+* Changes to the implementation of the rsync algorithm:
+ - use longer blocks for large files (the size of a block is the
+ square root of the size of the file for large files);
+ - transmit less checksum information per block (we still have less
+ than one chance in a hundred million of transferring a file
+ incorrectly, and Unison will catch any transfer error when
+ fingerprinting the whole file)
+ - avoid transfer overhead (which was 4 bytes per block)
+ For a 1G file, the first optimization saves a factor 50 on the
+ amount of data transferred from the target to the source (blocks
+ are 32768 bytes rather than just 700 bytes). The two other
+ optimizations save another factor of 2 (from 24 bytes per block
+ down to 10).
+
+* New "links" preference. When set to false, Unison will report an
+ error on symlinks during update detection. (This is the default
+ when one host is running Windows but not Cygwin.) This is better
+ than failing during propagation.
+* Added a preference "halfduplex" to force half-duplex communication
+ with the server. This may be useful on unreliable links (as a more
+ efficient alternative to "maxthreads = 1").
+* Renamed preference "pretendwin" to "ignoreinodenumbers" (an alias is
+ kept for backwards compatibility).
+* GTK UI: display estimated remaining time and transfer rate on the
+ progress bar
+* GTK UI: some polishing; in particular:
+ - stop statistics window updates when idle (save power on laptops)
+ - some ok and cancel buttons were in the wrong order
+
+* Added some support for making it easier to extend Unison without
+ breaking backwards compatibility.
+ - Possibility to mark a preference as local. Such a preference is
+ propagated if possible but will not result in an error if it is
+ not found server-side. This make it possible to add new
+ functionalities client-side without breaking compatibility.
+ - Added a function [Remove.commandAvailable] which tests whether a
+ command is available on a given root.
+* Removed hack in findUpdates that would update the archive in a
+ visible way for the sake of path translation: it is no longer
+ needed.
+
+-------------------------------
CHANGES FROM VERSION 2.36.-27
* Performance improvement in Xferhint module.
Modified: trunk/src/common.ml
===================================================================
--- trunk/src/common.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/common.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -112,9 +112,10 @@
type replicaContent =
{ typ : Fileinfo.typ;
status : status;
- desc : Props.t;
+ desc : Props.t; (* Properties (for the UI) *)
ui : updateItem;
- size : int * Uutil.Filesize.t }
+ size : int * Uutil.Filesize.t; (* Number of items and size *)
+ props : Props.t list } (* Parent properties *)
type direction =
Conflict
Modified: trunk/src/common.mli
===================================================================
--- trunk/src/common.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/common.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -90,9 +90,10 @@
type replicaContent =
{ typ : Fileinfo.typ;
status : status;
- desc : Props.t;
+ desc : Props.t; (* Properties (for the UI) *)
ui : updateItem;
- size : int * Uutil.Filesize.t }
+ size : int * Uutil.Filesize.t; (* Number of items and size *)
+ props : Props.t list } (* Parent properties *)
type direction =
Conflict
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/copy.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -409,9 +409,9 @@
fd
let rsyncReg = Lwt_util.make_region (40 * 1024)
-let rsyncThrottle useRsync sz f =
+let rsyncThrottle useRsync srcFileSize destFileSize f =
if not useRsync then f () else
- let l = Transfer.Rsync.memoryFootprint sz in
+ let l = Transfer.Rsync.memoryFootprint srcFileSize destFileSize in
Lwt_util.run_in_region rsyncReg l f
let transferFileContents
@@ -440,15 +440,17 @@
&&
Transfer.Rsync.aboveRsyncThreshold srcFileSize
in
- rsyncThrottle useRsync destFileSize (fun () ->
+ rsyncThrottle useRsync srcFileSize destFileSize (fun () ->
let (bi, decompr) =
if useRsync then
Util.convertUnixErrorsToTransient
"preprocessing file"
(fun () ->
let ifd = openFileIn fspathTo realPathTo fileKind in
- let bi =
- protect (fun () -> Transfer.Rsync.rsyncPreprocess ifd)
+ let (bi, blockSize) =
+ protect
+ (fun () -> Transfer.Rsync.rsyncPreprocess
+ ifd srcFileSize destFileSize)
(fun () -> close_in_noerr ifd)
in
infd := Some ifd;
@@ -459,7 +461,7 @@
destinationFd
fspathTo pathTo fileKind srcFileSize outfd id in
let eof =
- Transfer.Rsync.rsyncDecompress ifd fd showProgress ti
+ Transfer.Rsync.rsyncDecompress blockSize ifd fd showProgress ti
in
if eof then begin close_out fd; outfd := None end))
else
@@ -523,6 +525,48 @@
(****)
+let filesBeingTransferred = Hashtbl.create 17
+
+let wakeupNextTransfer fp =
+ match
+ try
+ Some (Queue.take (Hashtbl.find filesBeingTransferred fp))
+ with Queue.Empty ->
+ None
+ with
+ None ->
+ Hashtbl.remove filesBeingTransferred fp
+ | Some next ->
+ Lwt.wakeup next ()
+
+let executeTransfer fp f =
+ Lwt.try_bind f
+ (fun res -> wakeupNextTransfer fp; Lwt.return res)
+ (fun e -> wakeupNextTransfer fp; Lwt.fail e)
+
+(* Keep track of which file contents are being transferred, and delay
+ the transfer of a file with the same contents as another file being
+ currently transferred. This way, the second transfer can be
+ skipped and replaced by a local copy. *)
+let rec registerFileTransfer pathTo fp f =
+ if not (Prefs.read Xferhint.xferbycopying) then f () else
+ match
+ try Some (Hashtbl.find filesBeingTransferred fp) with Not_found -> None
+ with
+ None ->
+ let q = Queue.create () in
+ Hashtbl.add filesBeingTransferred fp q;
+ executeTransfer fp f
+ | Some q ->
+ debug (fun () -> Util.msg "delaying tranfer of file %s\n"
+ (Path.toString pathTo));
+ let res = Lwt.wait () in
+ Queue.push res q;
+ res >>= fun () ->
+ executeTransfer fp f
+
+(****)
+
let copyprog =
Prefs.createString "copyprog" "rsync --inplace --compress"
"!external program for copying large files"
@@ -631,7 +675,6 @@
Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return res
-
let finishExternalTransferOnRoot =
Remote.registerRootCmdWithConnection
"finishExternalTransfer" finishExternalTransferLocal
@@ -676,6 +719,8 @@
(snd rootFrom, pathFrom, fspathTo, pathTo, realPathTo,
update, desc, fp, ress, id)
+(****)
+
let transferFileLocal connFrom
(fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
update, desc, fp, ress, id) =
@@ -695,23 +740,25 @@
Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return (`DONE (Success info, Some msg))
end else
- match
- tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
- with
- Some (info, msg) ->
- (* Transfer was performed by copying *)
- Xferhint.insertEntry fspathTo pathTo fp;
- Lwt.return (`DONE (Success info, Some msg))
- | None ->
- if shouldUseExternalCopyprog update desc then
- Lwt.return (`EXTERNAL (prepareExternalTransfer fspathTo pathTo))
- else begin
- reallyTransferFile
- connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
- update desc fp ress id >>= fun status ->
- Xferhint.insertEntry fspathTo pathTo fp;
- Lwt.return (`DONE (status, None))
- end
+ registerFileTransfer pathTo fp
+ (fun () ->
+ match
+ tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
+ with
+ Some (info, msg) ->
+ (* Transfer was performed by copying *)
+ Xferhint.insertEntry fspathTo pathTo fp;
+ Lwt.return (`DONE (Success info, Some msg))
+ | None ->
+ if shouldUseExternalCopyprog update desc then
+ Lwt.return (`EXTERNAL (prepareExternalTransfer fspathTo pathTo))
+ else begin
+ reallyTransferFile
+ connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
+ update desc fp ress id >>= fun status ->
+ Xferhint.insertEntry fspathTo pathTo fp;
+ Lwt.return (`DONE (status, None))
+ end)
let transferFileOnRoot =
Remote.registerRootCmdWithConnection "transferFile" transferFileLocal
Modified: trunk/src/fileinfo.ml
===================================================================
--- trunk/src/fileinfo.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/fileinfo.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -18,6 +18,28 @@
let debugV = Util.debug "fileinfo+"
+let allowSymlinks =
+ Prefs.createString "links" "default"
+ "allow the synchronization of symbolic links (true/false/default)"
+ ("When set to {\\tt true}, this flag causes Unison to synchronize \
+ symbolic links. When the flag is set to {\\tt false}, symbolic \
+ links will result in an error during update detection. \
+ Ordinarily, when the flag is set to {\\tt default}, symbolic \
+ links are synchronized except when one of the hosts is running \
+ Windows. In rare circumstances it is useful to set the flag \
+ manually (e.g. when running Unison on a Unix system with a FAT \
+ [Windows] volume mounted).")
+
+let symlinksAllowed =
+ Prefs.createBool "links-aux" true
+ "*Pseudo-preference for internal use only" ""
+
+let init b =
+ Prefs.set symlinksAllowed
+ (Prefs.read allowSymlinks = "yes" ||
+ Prefs.read allowSymlinks = "true" ||
+ (Prefs.read allowSymlinks = "default" && not b))
+
type typ = [ `ABSENT | `FILE | `DIRECTORY | `SYMLINK ]
let type2string = function
@@ -58,7 +80,14 @@
match stats.Unix.LargeFile.st_kind with
Unix.S_REG -> `FILE
| Unix.S_DIR -> `DIRECTORY
- | Unix.S_LNK -> `SYMLINK
+ | Unix.S_LNK ->
+ if not fromRoot || Prefs.read symlinksAllowed then
+ `SYMLINK
+ else
+ raise
+ (Util.Transient
+ (Format.sprintf "path %s is a symbolic link"
+ (Fspath.toPrintString (Fspath.concat fspath path))))
| _ ->
raise (Util.Transient
("path " ^
@@ -121,15 +150,16 @@
probably not use any stamp under Windows. *)
let pretendLocalOSIsWin32 =
- Prefs.createBool "pretendwin" false
+ Prefs.createBool "ignoreinodenumbers" false
"!Use creation times for detecting updates"
- ("When set to true, this preference makes Unison use Windows-style "
- ^ "fast update detection (using file creation times as "
- ^ "``pseudo-inode-numbers''), even when running on a Unix system. This "
- ^ "switch should be used with care, as it is less safe than the standard "
- ^ "update detection method, but it can be useful for synchronizing VFAT "
- ^ "filesystems (which do not support inode numbers) mounted on Unix "
- ^ "systems. The {\\tt fastcheck} option should also be set to true.")
+ ("When set to true, this preference makes Unison not take advantage \
+ of inode numbers during fast update detection even when running \
+ on a Unix system. This switch should be used with care, as it \
+ is less safe than the standard update detection method, but it \
+ can be useful for synchronizing VFAT filesystems (which do not \
+ support inode numbers) mounted on Unix systems. \
+ The {\\tt fastcheck} option should also be set to true.")
+let _ = Prefs.alias pretendLocalOSIsWin32 "pretendwin"
let stamp info =
(* Was "CtimeStamp info.ctime", but this is bogus: Windows
Modified: trunk/src/fileinfo.mli
===================================================================
--- trunk/src/fileinfo.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/fileinfo.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -23,3 +23,7 @@
(* Check whether a file is unchanged *)
val unchanged : Fspath.t -> Path.local -> t -> (t * bool * bool)
+
+(****)
+
+val init : bool -> unit
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/files.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -319,6 +319,36 @@
let setupTargetPaths =
Remote.registerRootCmd "setupTargetPaths" setupTargetPathsLocal
+let rec createDirectories fspath localPath props =
+ match props with
+ [] ->
+ ()
+ | desc :: rem ->
+ match Path.deconstructRev localPath with
+ None ->
+ assert false
+ | Some (_, parentPath) ->
+ createDirectories fspath parentPath rem;
+ try
+ let absolutePath = Fspath.concat fspath parentPath in
+ Fs.mkdir absolutePath (Props.perms desc)
+ (* The directory may have already been created
+ if there are several paths with the same prefix *)
+ with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
+
+let setupTargetPathsAndCreateParentDirectoryLocal (fspath, (path, props)) =
+ let localPath = Update.translatePathLocal fspath path in
+ Util.convertUnixErrorsToTransient
+ "creating parent directories"
+ (fun () -> createDirectories fspath localPath props);
+ let (workingDir,realPath) = Fspath.findWorkingDir fspath localPath in
+ let tempPath = Os.tempPath ~fresh:false workingDir realPath in
+ Lwt.return (workingDir, realPath, tempPath, localPath)
+
+let setupTargetPathsAndCreateParentDirectory =
+ Remote.registerRootCmd "setupTargetPathsAndCreateParentDirectory"
+ setupTargetPathsAndCreateParentDirectoryLocal
+
(* ------------------------------------------------------------ *)
let updateSourceArchiveLocal (fspathFrom, (localPathFrom, uiFrom, errPaths)) =
@@ -376,6 +406,15 @@
let deleteSpuriousChildren =
Remote.registerRootCmd "deleteSpuriousChildren" deleteSpuriousChildrenLocal
+let rec normalizePropsRec propsFrom propsTo =
+ match propsFrom, propsTo with
+ d :: r, d' :: r' -> normalizePropsRec r r'
+ | _, [] -> propsFrom
+ | [], _ :: _ -> assert false
+
+let normalizeProps propsFrom propsTo =
+ normalizePropsRec (Safelist.rev propsFrom) (Safelist.rev propsTo)
+
(* ------------------------------------------------------------ *)
let copyReg = Lwt_util.make_region 50
@@ -385,10 +424,13 @@
rootFrom pathFrom (* copy from here... *)
uiFrom (* (and then check that this updateItem still
describes the current state of the src replica) *)
+ propsFrom (* the properties of the parent directories, in
+ case we need to propagate them *)
rootTo pathTo (* ...to here *)
uiTo (* (but, before committing the copy, check that
this updateItem still describes the current
state of the target replica) *)
+ propsTo (* the properties of the parent directories *)
id = (* for progress display *)
debug (fun() ->
Util.msg
@@ -396,7 +438,8 @@
(root2string rootFrom) (Path.toString pathFrom)
(root2string rootTo) (Path.toString pathTo));
(* Calculate target paths *)
- setupTargetPaths rootTo pathTo
+ setupTargetPathsAndCreateParentDirectory rootTo
+ (pathTo, normalizeProps propsFrom propsTo)
>>= fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
(* When in Unicode case-insensitive mode, we want to create files
with NFC normal-form filenames. *)
Modified: trunk/src/files.mli
===================================================================
--- trunk/src/files.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/files.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -26,9 +26,11 @@
-> Common.root (* from what root *)
-> Path.t (* from what path *)
-> Common.updateItem (* source updates *)
+ -> Props.t list (* properties of parent directories *)
-> Common.root (* to what root *)
-> Path.t (* to what path *)
-> Common.updateItem (* dest. updates *)
+ -> Props.t list (* properties of parent directories *)
-> Uutil.File.t (* id for showing progress of transfer *)
-> unit Lwt.t
Modified: trunk/src/globals.ml
===================================================================
--- trunk/src/globals.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/globals.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -162,7 +162,7 @@
(* FIX: this does weird things in case-insensitive mode... *)
let globPath lr p =
- let p = Path.magic p in
+ let p = Path.forceLocal p in
debug (fun() ->
Util.msg "Checking path '%s' for expansions\n"
(Path.toDebugString p) );
@@ -175,10 +175,10 @@
(Path.toString p)
"but first root (after canonizing) is non-local"))
| Some lrfspath ->
- Safelist.map (fun c -> Path.magic' (Path.child parent c))
+ Safelist.map (fun c -> Path.makeGlobal (Path.child parent c))
(Os.childrenOf lrfspath parent)
end
- | _ -> [Path.magic' p]
+ | _ -> [Path.makeGlobal p]
let expandWildcardPaths() =
let lr =
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/mkProjectInfo.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -5,8 +5,8 @@
let projectName = "unison"
let majorVersion = 2
-let minorVersion = 36
-let pointVersionOrigin = 359 (* Revision that corresponds to point version 0 *)
+let minorVersion = 37
+let pointVersionOrigin = 377 (* Revision that corresponds to point version 0 *)
(* Documentation:
This is a program to construct a version of the form Major.Minor.Point,
@@ -65,7 +65,7 @@
Str.matched_group 1 str;;
let extract_int re str = int_of_string (extract_str re str);;
-let revisionString = "$Rev: 332$";;
+let revisionString = "$Rev: 378$";;
let pointVersion = if String.length revisionString > 5
then Scanf.sscanf revisionString "$Rev: %d " (fun x -> x) - pointVersionOrigin
else (* Determining the pointVersionOrigin in bzr is kind of tricky:
@@ -96,3 +96,4 @@
+
Modified: trunk/src/path.ml
===================================================================
--- trunk/src/path.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/path.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -207,5 +207,5 @@
(Util.osType = `Unix || Util.isCygwin)
&& Pred.test followPred (toString path)
-let magic p = p
-let magic' p = p
+let forceLocal p = p
+let makeGlobal p = p
Modified: trunk/src/path.mli
===================================================================
--- trunk/src/path.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/path.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -36,5 +36,5 @@
val followLink : local -> bool
val followPred : Pred.t
-val magic : t -> local
-val magic' : local -> t
+val forceLocal : t -> local
+val makeGlobal : local -> t
Modified: trunk/src/props.ml
===================================================================
--- trunk/src/props.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/props.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -146,7 +146,9 @@
else
off
in
- bit 0o1000 "" "" "t" ^
+ bit 0o4000 "" "-" "S" ^
+ bit 0o2000 "" "-" "s" ^
+ bit 0o1000 "?" "" "t" ^
bit 0o0400 "?" "-" "r" ^
bit 0o0200 "?" "-" "w" ^
bit 0o0100 "?" "-" "x" ^
@@ -169,7 +171,9 @@
else
off
in
- bit 0o1000 "" "" "t" ^
+ bit 0o4000 "" "-" "S" ^
+ bit 0o2000 "" "-" "s" ^
+ bit 0o1000 "?" "" "t" ^
bit 0o0400 "?" "-" "r" ^
bit 0o0200 "?" "-" "w" ^
bit 0o0100 "?" "-" "x" ^
Modified: trunk/src/recon.ml
===================================================================
--- trunk/src/recon.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/recon.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -247,44 +247,44 @@
type singleUpdate = Rep1Updated | Rep2Updated
-let update2replicaContent path (conflict: bool) ui ucNew oldType:
+let update2replicaContent path (conflict: bool) ui props ucNew oldType:
Common.replicaContent =
let size = Update.updateSize path ui in
match ucNew with
Absent ->
{typ = `ABSENT; status = `Deleted; desc = Props.dummy;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| File (desc, ContentsSame) ->
{typ = `FILE; status = `PropsChanged; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| File (desc, _) when oldType <> `FILE ->
{typ = `FILE; status = `Created; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| File (desc, ContentsUpdated _) ->
{typ = `FILE; status = `Modified; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Symlink l when oldType <> `SYMLINK ->
{typ = `SYMLINK; status = `Created; desc = Props.dummy;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Symlink l ->
{typ = `SYMLINK; status = `Modified; desc = Props.dummy;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, _, _) when oldType <> `DIRECTORY ->
{typ = `DIRECTORY; status = `Created; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, PropsUpdated, _) ->
{typ = `DIRECTORY; status = `PropsChanged; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, PropsSame, _) when conflict ->
(* Special case: the directory contents has been modified and the *)
(* directory is in conflict. (We don't want to display a conflict *)
(* between an unchanged directory and a file, for instance: this would *)
(* be rather puzzling to the user) *)
{typ = `DIRECTORY; status = `Modified; desc = desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
| Dir (desc, _, PropsSame, _) ->
{typ = `DIRECTORY; status = `Unchanged; desc =desc;
- ui = ui; size = size}
+ ui = ui; size = size; props = props}
let oldType (prev: Common.prevState): Fileinfo.typ =
match prev with
@@ -297,25 +297,26 @@
| New -> Props.dummy
(* [describeUpdate ui] returns the replica contents for both the case of *)
-(* updating and the case of non-updatingd *)
-let describeUpdate path ui
+(* updating and the case of non-updating *)
+let describeUpdate path props' ui props
: Common.replicaContent * Common.replicaContent =
match ui with
Updates (ucNewStatus, prev) ->
let typ = oldType prev in
- (update2replicaContent path false ui ucNewStatus typ,
+ (update2replicaContent path false ui props ucNewStatus typ,
{typ = typ; status = `Unchanged; desc = oldDesc prev;
- ui = NoUpdates; size = Update.updateSize path NoUpdates})
+ ui = NoUpdates; size = Update.updateSize path NoUpdates;
+ props = props'})
| _ -> assert false
(* Computes the reconItems when only one side has been updated. (We split *)
(* this out into a separate function to avoid duplicating all the symmetric *)
(* cases.) *)
-let rec reconcileNoConflict allowPartial path ui whatIsUpdated
+let rec reconcileNoConflict allowPartial path props' ui props whatIsUpdated
(result: (Name.t * Name.t, Common.replicas) Tree.u)
: (Name.t * Name.t, Common.replicas) Tree.u =
let different() =
- let rcUpdated, rcNotUpdated = describeUpdate path ui in
+ let rcUpdated, rcNotUpdated = describeUpdate path props' ui props in
match whatIsUpdated with
Rep2Updated ->
Different {rc1 = rcNotUpdated; rc2 = rcUpdated;
@@ -340,7 +341,8 @@
(fun result (theName, uiChild) ->
Tree.leave
(reconcileNoConflict allowPartial (Path.child path theName)
- uiChild whatIsUpdated (Tree.enter result (theName, theName))))
+ [] uiChild [] whatIsUpdated
+ (Tree.enter result (theName, theName))))
r children
| Updates _ ->
Tree.add result (propagateErrors allowPartial (different ()))
@@ -393,21 +395,26 @@
(* Tree.u *)
(* unequals: (Name.t * Name.t, Common.replicas) Tree.u *)
(* -- *)
-let rec reconcile allowPartial path ui1 ui2 counter (equals:(_*_,_)Tree.u) unequals =
+let rec reconcile
+ allowPartial path ui1 props1 ui2 props2 counter equals unequals =
let different uc1 uc2 oldType equals unequals =
(equals,
Tree.add unequals
(propagateErrors allowPartial
- (Different {rc1 = update2replicaContent path true ui1 uc1 oldType;
- rc2 = update2replicaContent path true ui2 uc2 oldType;
+ (Different {rc1 = update2replicaContent
+ path true ui1 props1 uc1 oldType;
+ rc2 = update2replicaContent
+ path true ui2 props2 uc2 oldType;
direction = Conflict; default_direction = Conflict;
errors1 = []; errors2 = []}))) in
let toBeMerged uc1 uc2 oldType equals unequals =
(equals,
Tree.add unequals
(propagateErrors allowPartial
- (Different {rc1 = update2replicaContent path true ui1 uc1 oldType;
- rc2 = update2replicaContent path true ui2 uc2 oldType;
+ (Different {rc1 = update2replicaContent
+ path true ui1 props1 uc1 oldType;
+ rc2 = update2replicaContent
+ path true ui2 props2 uc2 oldType;
direction = Merge; default_direction = Merge;
errors1 = []; errors2 = []}))) in
match (ui1, ui2) with
@@ -416,9 +423,13 @@
| (_, Error s) ->
(equals, Tree.add unequals (Problem s))
| (NoUpdates, _) ->
- (equals, reconcileNoConflict allowPartial path ui2 Rep2Updated unequals)
+ (equals,
+ reconcileNoConflict
+ allowPartial path props1 ui2 props2 Rep2Updated unequals)
| (_, NoUpdates) ->
- (equals, reconcileNoConflict allowPartial path ui1 Rep1Updated unequals)
+ (equals,
+ reconcileNoConflict
+ allowPartial path props2 ui1 props1 Rep1Updated unequals)
| (Updates (Absent, _), Updates (Absent, _)) ->
(add_equal counter equals (Absent, Absent), unequals)
| (Updates (Dir (desc1, children1, propsChanged1, _) as uc1, prevState1),
@@ -439,8 +450,8 @@
(equals,
Tree.add unequals
(Different
- {rc1 = update2replicaContent path false ui1 uc1 `DIRECTORY;
- rc2 = update2replicaContent path false ui2 uc2 `DIRECTORY;
+ {rc1 = update2replicaContent path false ui1 [] uc1 `DIRECTORY;
+ rc2 = update2replicaContent path false ui2 [] uc2 `DIRECTORY;
direction = action; default_direction = action;
errors1 = []; errors2 = []}))
in
@@ -448,7 +459,8 @@
Safelist.fold_left
(fun (equals, unequals) (name1,ui1,name2,ui2) ->
let (eq, uneq) =
- reconcile allowPartial (Path.child path name1) ui1 ui2 counter
+ reconcile
+ allowPartial (Path.child path name1) ui1 [] ui2 [] counter
(Tree.enter equals (name1, name2))
(Tree.enter unequals (name1, name2))
in
@@ -521,16 +533,22 @@
(* file that is updated in the same way on both roots *)
let reconcileList allowPartial
(pathUpdatesList:
- (Path.t * Common.updateItem * Path.t * Common.updateItem) list)
+ ((Path.local * Common.updateItem * Props.t list) *
+ (Path.local * Common.updateItem * Props.t list)) list)
: Common.reconItem list * bool * Path.t list =
let counter = ref 0 in
let archiveUpdated = ref false in
let (equals, unequals, dangerous) =
Safelist.fold_left
- (fun (equals, unequals, dangerous) (path1,ui1,path2,ui2) ->
+ (fun (equals, unequals, dangerous)
+ ((path1,ui1,props1),(path2,ui2,props2)) ->
+ (* We make the paths global as we may concatenate them with
+ names from the other replica *)
+ let path1 = Path.makeGlobal path1 in
+ let path2 = Path.makeGlobal path2 in
let (equals, unequals) =
reconcile allowPartial
- path1 ui1 ui2 (counter, archiveUpdated)
+ path1 ui1 props1 ui2 props2 (counter, archiveUpdated)
(enterPath path1 path2 equals)
(enterPath path1 path2 unequals)
in
Modified: trunk/src/recon.mli
===================================================================
--- trunk/src/recon.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/recon.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -4,7 +4,8 @@
val reconcileAll :
?allowPartial:bool (* whether we allow partial synchronization
of directories (default to false) *)
- -> (Path.t * Common.updateItem * Path.t * Common.updateItem) list
+ -> ((Path.local * Common.updateItem * Props.t list) *
+ (Path.local * Common.updateItem * Props.t list)) list
(* one updateItem per replica, per path *)
-> Common.reconItem list (* List of updates that need propagated *)
* bool (* Any file updated equally on all roots*)
Modified: trunk/src/remote.ml
===================================================================
--- trunk/src/remote.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/remote.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -270,7 +270,6 @@
to the requests to be processed *)
Lwt.ignore_result (Lwt_unix.yield () >>= fun () -> popOutputQueues q)
-
let disableFlowControl q =
q.flowControl <- false;
if not q.canWrite then allowWrites q
@@ -315,6 +314,7 @@
flushBuffer buf
end else
flushBuffer buf) >>= fun () ->
+ assert (not (q.flowControl && q.canWrite));
(* Restart the reader thread if needed *)
match !receiver with
None -> Lwt.return ()
@@ -894,6 +894,10 @@
(fun e -> ping conn id >>= fun () -> Lwt.fail e)
end
+let commandAvailable =
+ registerRootCmd "commandAvailable"
+ (fun (_, cmdName) -> Lwt.return (Util.StringMap.mem cmdName !serverCmds))
+
(****************************************************************************
BUILDING CONNECTIONS TO THE SERVER
****************************************************************************)
@@ -933,6 +937,16 @@
Both hosts must use non-blocking I/O (otherwise a dead-lock is
possible with ssh).
*)
+let halfduplex =
+ Prefs.createBool "halfduplex" false
+ "!force half-duplex communication with the server"
+ "When this flag is set to {\\tt true}, Unison network communication \
+ is forced to be half duplex (the client and the server never \
+ simultaneously emit data). If you experience unstabilities with \
+ your network link, this may help. The communication is always \
+ half-duplex when synchronizing with a Windows machine due to a \
+ limitation of Unison current implementation that could result \
+ in a deadlock."
let negociateFlowControlLocal conn () =
if not needFlowControl then disableFlowControl conn.outputQueue;
@@ -942,14 +956,14 @@
registerServerCmd "negociateFlowControl" negociateFlowControlLocal
let negociateFlowControl conn =
- if not needFlowControl then
- negociateFlowControlRemote conn () >>= (fun needed ->
- if not needed then
- negociateFlowControlLocal conn () >>= (fun _ -> Lwt.return ())
- else
- Lwt.return ())
- else
- Lwt.return ()
+ (* Flow control negociation can be done asynchronously. *)
+ if not (needFlowControl || Prefs.read halfduplex) then
+ Lwt.ignore_result
+ (negociateFlowControlRemote conn () >>= fun needed ->
+ if not needed then
+ negociateFlowControlLocal conn ()
+ else
+ Lwt.return true)
(****)
@@ -960,8 +974,7 @@
checkHeader
conn (Bytearray.create 1) 0 (String.length connectionHeader) >>= (fun () ->
Lwt.ignore_result (receive conn);
- (* Flow control negociation can be done asynchronously. *)
- Lwt.ignore_result (negociateFlowControl conn);
+ negociateFlowControl conn;
Lwt.return conn)
let inetAddr host =
Modified: trunk/src/remote.mli
===================================================================
--- trunk/src/remote.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/remote.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -32,6 +32,12 @@
-> 'a (* additional arguments *)
-> 'b Lwt.t) (* -> (suspended) result *)
+(* Test whether a command exits on some root *)
+val commandAvailable :
+ Common.root -> (* root *)
+ string -> (* command name *)
+ bool Lwt.t
+
(* Enter "server mode", reading and processing commands from a remote
client process until killed *)
val beAServer : unit -> unit
Modified: trunk/src/transfer.ml
===================================================================
--- trunk/src/transfer.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/transfer.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -94,8 +94,7 @@
| EOF
(* Size of a block *)
-let blockSize = 700
-let blockSize64 = Int64.of_int blockSize
+let minBlockSize = 700
let maxQueueSize = 65500
let maxQueueSizeFS = Uutil.Filesize.ofInt maxQueueSize
@@ -105,16 +104,9 @@
(* some informations about the
previous token *)
mutable pos : int; (* head of the queue *)
- mutable prog : int } (* the size of the data they represent *)
+ mutable prog : int; (* the size of the data they represent *)
+ mutable bSize : int } (* block size *)
-(* Size of the data a token represents for the destination host,
- to keep track of the propagation progress *)
-let tokenProg t =
- match t with
- STRING (s, pos, len) -> String.length s
- | BLOCK n -> blockSize
- | EOF -> 0
-
let encodeInt3 s pos i =
assert (i >= 0 && i < 256 * 256 * 256);
s.{pos + 0} <- Char.chr ((i lsr 0) land 0xff);
@@ -199,7 +191,7 @@
encodeInt3 q.data (q.pos + 1) pos;
encodeInt1 q.data (q.pos + 4) 1;
q.pos <- q.pos + 5;
- q.prog <- q.prog + blockSize;
+ q.prog <- q.prog + q.bSize;
q.previous <- `Block (pos + 1);
return ())
@@ -209,7 +201,7 @@
assert (decodeInt3 q.data (q.pos - 4) + count = pos);
assert (count < 255);
encodeInt1 q.data (q.pos - 1) (count + 1);
- q.prog <- q.prog + blockSize;
+ q.prog <- q.prog + q.bSize;
q.previous <- if count = 254 then `None else `Block (pos + 1);
return ()
@@ -229,7 +221,7 @@
| BLOCK pos, _ ->
pushBlock q id transmit pos
-let makeQueue length =
+let makeQueue length blockSize =
{ data =
(* We need to make sure here that the size of the queue is not
larger than 65538
@@ -237,7 +229,8 @@
Bytearray.create
(if length > maxQueueSizeFS then maxQueueSize else
Uutil.Filesize.toInt length + 10);
- pos = 0; previous = `None; prog = 0 }
+ pos = 0; previous = `None; prog = 0;
+ bSize = blockSize }
(*************************************************************************)
(* GENERIC TRANSMISSION *)
@@ -252,7 +245,7 @@
let bufSz = 8192 in
let bufSzFS = Uutil.Filesize.ofInt 8192 in
let buf = String.create bufSz in
- let q = makeQueue length in
+ let q = makeQueue length 0 in
let rec sendSlice length =
let count =
reallyRead infd buf 0
@@ -303,75 +296,116 @@
(* It is impossible to use rsync when the file size is smaller than
the size of a block *)
- let blockSizeFs = Uutil.Filesize.ofInt blockSize
- let aboveRsyncThreshold sz = sz >= blockSizeFs
+ let minBlockSizeFs = Uutil.Filesize.ofInt minBlockSize
+ let aboveRsyncThreshold sz = sz > minBlockSizeFs
(* The type of the info that will be sent to the source host *)
- type rsync_block_info = (Checksum.t * Digest.t) list
+ type rsync_block_info =
+ { blockSize : int;
+ blockCount : int;
+ checksumSize : int;
+ weakChecksum :
+ (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t;
+ strongChecksum : Bytearray.t }
-
(*** PREPROCESS ***)
- (* Preprocess buffer size *)
- let preproBufSize = 8192
+ (* Worst case probability of a failure *)
+ let logProba = -27. (* One time in 100 millions *)
+ (* Strength of the weak checksum
+ (how many bit of the weak checksum we can rely on) *)
+ let weakLen = 27.
+ (* This is what rsync uses:
+ let logProba = -10.
+ let weakLen = 31.
+ This would save almost 3 bytes per block, but one need to be able
+ to recover from an rsync error.
+ *)
+ (* Block size *)
+ let computeBlockSize l = truncate (max 700. (min (sqrt l) 131072.))
+ (* Size of each strong checksum *)
+ let checksumSize bs sl dl =
+ let bits =
+ -. logProba -. weakLen +. log (sl *. dl /. float bs) /. log 2. in
+ max 2 (min 16 (truncate ((bits +. 7.99) /. 8.)))
+ let sizes srcLength dstLength =
+ let blockSize = computeBlockSize (Uutil.Filesize.toFloat dstLength) in
+ let blockCount =
+ let count =
+ Int64.div (Uutil.Filesize.toInt64 dstLength) (Int64.of_int blockSize)
+ in
+ Int64.to_int (min 16777216L count)
+ in
+ let csSize =
+ checksumSize blockSize
+ (Uutil.Filesize.toFloat srcLength)(Uutil.Filesize.toFloat dstLength)
+ in
+ (blockSize, blockCount, csSize)
+
(* Incrementally build arg by executing f on successive blocks (of size
'blockSize') of the input stream (pointed by 'infd').
The procedure uses a buffer of size 'bufferSize' to load the input,
and eventually handles the buffer update. *)
- let blockIter infd f arg maxCount =
+ let blockIter infd f blockSize maxCount =
let bufferSize = 8192 + blockSize in
let buffer = String.create bufferSize in
- let rec iter count arg offset length =
- if count = maxCount then arg else begin
+ let rec iter count offset length =
+ if count = maxCount then
+ count
+ else begin
let newOffset = offset + blockSize in
- if newOffset <= length then
- iter (count + 1) (f buffer offset arg) newOffset length
- else if offset > 0 then begin
+ if newOffset <= length then begin
+ f count buffer offset;
+ iter (count + 1) newOffset length
+ end else if offset > 0 then begin
let chunkSize = length - offset in
String.blit buffer offset buffer 0 chunkSize;
- iter count arg 0 chunkSize
+ iter count 0 chunkSize
end else begin
let l = input infd buffer length (bufferSize - length) in
if l = 0 then
- arg
+ count
else
- iter count arg 0 (length + l)
+ iter count 0 (length + l)
end
end
in
- iter 0 arg 0 0
+ iter 0 0 0
(* Given a block size, get blocks from the old file and compute a
checksum and a fingerprint for each one. *)
- let rsyncPreprocess infd =
+ let rsyncPreprocess infd srcLength dstLength =
debug (fun() -> Util.msg "preprocessing\n");
- debugLog (fun() -> Util.msg "block size = %d bytes\n" blockSize);
+ let (blockSize, blockCount, csSize) = sizes srcLength dstLength in
+ debugLog (fun() ->
+ Util.msg "block size = %d bytes; block count = %d; \
+ strong checksum size = %d\n" blockSize blockCount csSize);
let timer = Trace.startTimer "Preprocessing old file" in
- let addBlock buf offset rev_bi =
- let cs = Checksum.substring buf offset blockSize in
- let fp = Digest.substring buf offset blockSize in
- (cs, fp) :: rev_bi
+ let weakCs =
+ Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout blockCount in
+ let strongCs = Bytearray.create (blockCount * csSize) in
+ let addBlock i buf offset =
+ weakCs.{i} <- Int32.of_int (Checksum.substring buf offset blockSize);
+ Bytearray.blit_from_string
+ (Digest.substring buf offset blockSize) 0 strongCs (i * csSize) csSize
in
(* Make sure we are at the beginning of the file
(important for AppleDouble files *)
LargeFile.seek_in infd 0L;
(* Limit the number of block so that there is no overflow in
encodeInt3 *)
- let rev_bi = blockIter infd addBlock [] (256*256*256) in
- let bi = Safelist.rev rev_bi in
- debugLog (fun() -> Util.msg "%d blocks\n" (Safelist.length bi));
+ let count = blockIter infd addBlock blockSize (256*256*256) in
+ debugLog (fun() -> Util.msg "%d blocks\n" count);
Trace.showTimer timer;
- bi
+ ({ blockSize = blockSize; blockCount = count; checksumSize = csSize;
+ weakChecksum = weakCs; strongChecksum = strongCs },
+ blockSize)
(* Expected size of the [rsync_block_info] datastructure (in KiB). *)
- (* The calculation here are for a 64 bit architecture. *)
- (* When serialized, the datastructure takes currently 24 bytes per block. *)
- (* In theory, 12 byte per block should be enough! *)
- let memoryFootprint sz =
- Int64.to_int
- (min (Int64.div (Uutil.Filesize.toInt64 sz) 716800L) 16384L)
- * 72
+ let memoryFootprint srcLength dstLength =
+ let (blockSize, blockCount, csSize) = sizes srcLength dstLength in
+ blockCount * (csSize + 4)
(*** DECOMPRESSION ***)
@@ -380,7 +414,7 @@
(* For each transfer instruction, either output a string or copy one or
several blocks from the old file. *)
- let rsyncDecompress infd outfd showProgress (data, pos, len) =
+ let rsyncDecompress blockSize infd outfd showProgress (data, pos, len) =
let decomprBuf = String.create decomprBufSize in
let progress = ref 0 in
let rec copy length =
@@ -393,7 +427,7 @@
reallyWrite outfd decomprBuf 0 length
in
let copyBlocks n k =
- LargeFile.seek_in infd (Int64.mul n blockSize64);
+ LargeFile.seek_in infd (Int64.mul n (Int64.of_int blockSize));
let length = k * blockSize in
copy length;
progress := !progress + length
@@ -435,42 +469,33 @@
(* Maximum number of entries in the hash table.
MUST be a power of 2 !
Typical values are around an average 2 * fileSize / blockSize. *)
- let hashTableMaxLength = 64 * 1024
+ let hashTableMaxLength = 2048 * 1024
+ let rec upperPowerOfTwo n n2 =
+ if (n2 >= n) || (n2 = hashTableMaxLength) then
+ n2
+ else
+ upperPowerOfTwo n (2 * n2)
+
let hash checksum = checksum
(* Compute the hash table length as a function of the number of blocks *)
let hashTableLength signatures =
- let rec upperPowerOfTwo n n2 =
- if (n2 >= n) || (n2 = hashTableMaxLength) then
- n2
- else
- upperPowerOfTwo n (2 * n2)
- in
- 2 * (upperPowerOfTwo (Safelist.length signatures) 32)
+ 2 * (upperPowerOfTwo signatures.blockCount 32)
(* Hash the block signatures into the hash table *)
let hashSig hashTableLength signatures =
let hashTable = Array.make hashTableLength [] in
- let rec addList k l =
- match l with
- [] ->
- ()
- | (cs, fp) :: r ->
- (* Negative 31-bits integers are sign-extended when
- unmarshalled on a 64-bit architecture, so we
- truncate them back to 31 bits. *)
- let cs = cs land 0x7fffffff in
- let h = (hash cs) land (hashTableLength - 1) in
- hashTable.(h) <- (k, cs, fp)::(hashTable.(h));
- addList (k + 1) r
- in
- addList 0 signatures;
+ for k = 0 to signatures.blockCount - 1 do
+ let cs = Int32.to_int signatures.weakChecksum.{k} land 0x7fffffff in
+ let h = (hash cs) land (hashTableLength - 1) in
+ hashTable.(h) <- (k, cs) :: hashTable.(h)
+ done;
hashTable
(* Given a key, retrieve the corresponding entry in the table *)
let findEntry hashTable hashTableLength checksum :
- (int * Checksum.t * Digest.t) list =
+ (int * Checksum.t) list =
hashTable.((hash checksum) land (hashTableLength - 1))
(* Log the values of the parameters associated with the hash table *)
@@ -527,12 +552,14 @@
(* Compression buffer size *)
(* MUST be >= 2 * blockSize *)
- let comprBufSize = 8192
- let comprBufSizeFS = Uutil.Filesize.ofInt 8192
+ let minComprBufSize = 8192
(* Compress the file using the algorithm described in the header *)
let rsyncCompress sigs infd srcLength showProgress transmit =
debug (fun() -> Util.msg "compressing\n");
+ let blockSize = sigs.blockSize in
+ let comprBufSize = (2 * blockSize + 8191) land (-8192) in
+ let comprBufSizeFS = Uutil.Filesize.ofInt comprBufSize in
debugLog (fun() -> Util.msg
"compression buffer size = %d bytes\n" comprBufSize);
debugLog (fun() -> Util.msg "block size = %d bytes\n" blockSize);
@@ -564,7 +591,7 @@
*)
(* Enable token buffering *)
- let tokenQueue = makeQueue srcLength in
+ let tokenQueue = makeQueue srcLength blockSize in
let flushTokenQueue () =
flushQueue tokenQueue showProgress transmit true in
let transmit token = queueToken tokenQueue showProgress transmit token in
@@ -574,6 +601,17 @@
let blockTable = hashSig !hashTableLength sigs in
logHash blockTable !hashTableLength;
+ let rec fingerprintMatchRec checksums pos fp i =
+ let i = i - 1 in
+ i < 0 ||
+ (String.unsafe_get fp i = checksums.{pos + i} &&
+ fingerprintMatchRec checksums pos fp i)
+ in
+ let fingerprintMatch k fp =
+ fingerprintMatchRec sigs.strongChecksum (k * sigs.checksumSize)
+ fp sigs.checksumSize
+ in
+
(* Create the compression buffer *)
let comprBuf = String.create comprBufSize in
@@ -661,12 +699,12 @@
match entry, fingerprint with
| [], _ ->
-1
- | (k, cs, fp) :: tl, None
+ | (k, cs) :: tl, None
when cs = checksum ->
let fingerprint = Digest.substring comprBuf offset blockSize in
findBlock offset checksum entry (Some fingerprint)
- | (k, cs, fp) :: tl, Some fingerprint
- when (cs = checksum) && (fp = fingerprint) ->
+ | (k, cs) :: tl, Some fingerprint
+ when cs = checksum && fingerprintMatch k fingerprint ->
k
| _ :: tl, _ ->
findBlock offset checksum tl fingerprint
Modified: trunk/src/transfer.mli
===================================================================
--- trunk/src/transfer.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/transfer.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -78,16 +78,19 @@
type rsync_block_info
(* Expected size of the [rsync_block_info] datastructure (in KiB). *)
- val memoryFootprint : Uutil.Filesize.t -> int
+ val memoryFootprint : Uutil.Filesize.t -> Uutil.Filesize.t -> int
(* Compute block informations from the old file *)
val rsyncPreprocess :
in_channel (* old file descriptor *)
- -> rsync_block_info
+ -> Uutil.Filesize.t (* source file length *)
+ -> Uutil.Filesize.t (* destination file length *)
+ -> rsync_block_info * int
(* Interpret a transfer instruction *)
val rsyncDecompress :
- in_channel (* old file descriptor *)
+ int (* block size *)
+ -> in_channel (* old file descriptor *)
-> out_channel (* output file descriptor *)
-> (int -> unit) (* progress report *)
-> transfer_instruction (* transfer instruction received *)
Modified: trunk/src/transport.ml
===================================================================
--- trunk/src/transport.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/transport.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -120,8 +120,8 @@
("Updating file " ^ Path.toString toPath)
(fun () ->
Files.copy (`Update (fileSize uiFrom uiTo))
- fromRoot fromPath uiFrom toRoot toPath uiTo id)
- | {ui = uiFrom}, {ui = uiTo} ->
+ fromRoot fromPath uiFrom [] toRoot toPath uiTo [] id)
+ | {ui = uiFrom; props = propsFrom}, {ui = uiTo; props = propsTo} ->
logLwtNumbered
("Copying " ^ Path.toString toPath ^ "\n from " ^
root2string fromRoot ^ "\n to " ^
@@ -129,7 +129,8 @@
("Copying " ^ Path.toString toPath)
(fun () ->
Files.copy `Copy
- fromRoot fromPath uiFrom toRoot toPath uiTo id))
+ fromRoot fromPath uiFrom propsFrom
+ toRoot toPath uiTo propsTo id))
(fun e -> Trace.log
(Printf.sprintf
"Failed: %s\n" (Util.printException e));
Modified: trunk/src/ubase/prefs.ml
===================================================================
--- trunk/src/ubase/prefs.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/ubase/prefs.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -56,30 +56,33 @@
(* created, a dumper (marshaler) and a loader (parser) are added to the list *)
(* kept here... *)
-type dumpedPrefs = (string * string) list
+type dumpedPrefs = (string * bool * string) list
-let dumpers = ref ([] : (string * (unit->string)) list)
+let dumpers = ref ([] : (string * bool * (unit->string)) list)
let loaders = ref (Util.StringMap.empty : (string->unit) Util.StringMap.t)
-let adddumper name f =
- dumpers := (name,f) :: !dumpers
+let adddumper name optional f =
+ dumpers := (name,optional,f) :: !dumpers
let addloader name f =
loaders := Util.StringMap.add name f !loaders
-let dump () = Safelist.map (fun (name,f) -> (name, f())) !dumpers
-
+let dump () = Safelist.map (fun (name, opt, f) -> (name, opt, f())) !dumpers
+
let load d =
- begin
- Safelist.iter
- (fun (name, dumpedval) ->
- let loaderfn =
- try Util.StringMap.find name !loaders
- with Not_found -> raise (Util.Fatal
- ("Preference "^name^" not found: inconsistent Unison versions??"))
- in loaderfn dumpedval)
- d
- end
+ Safelist.iter
+ (fun (name, opt, dumpedval) ->
+ match
+ try Some (Util.StringMap.find name !loaders) with Not_found -> None
+ with
+ Some loaderfn ->
+ loaderfn dumpedval
+ | None ->
+ if not opt then
+ raise (Util.Fatal
+ ("Preference "^name^" not found: \
+ inconsistent Unison versions??")))
+ d
(* For debugging *)
let dumpPrefsToStderr() =
@@ -117,42 +120,42 @@
raise (Util.Fatal ("Preference " ^ name ^ " registered twice"));
prefs := Util.StringMap.add name (doc, pspec, fulldoc) !prefs
-let createPrefInternal name default doc fulldoc printer parsefn =
+let createPrefInternal name local default doc fulldoc printer parsefn =
let newCell = rawPref (default, [name]) in
registerPref name (parsefn newCell) doc fulldoc;
- adddumper name (fun () -> Marshal.to_string !newCell []);
+ adddumper name local (fun () -> Marshal.to_string !newCell []);
addprinter name (fun () -> printer (fst !newCell));
addresetter (fun () -> newCell := (default, [name]));
addloader name (fun s -> newCell := Marshal.from_string s 0);
newCell
-let create name default doc fulldoc intern printer =
- createPrefInternal name default doc fulldoc printer
+let create name ?(local=false) default doc fulldoc intern printer =
+ createPrefInternal name local default doc fulldoc printer
(fun cell -> Uarg.String (fun s -> set cell (intern (fst !cell) s)))
-let createBool name default doc fulldoc =
+let createBool name ?(local=false) default doc fulldoc =
let doc = if default then doc ^ " (default true)" else doc in
- createPrefInternal name default doc fulldoc
+ createPrefInternal name local default doc fulldoc
(fun v -> [if v then "true" else "false"])
(fun cell -> Uarg.Bool (fun b -> set cell b))
-let createInt name default doc fulldoc =
- createPrefInternal name default doc fulldoc
- (fun v -> [string_of_int v])
+let createInt name ?(local=false) default doc fulldoc =
+ createPrefInternal name local default doc fulldoc
+ (fun v -> [string_of_int v])
(fun cell -> Uarg.Int (fun i -> set cell i))
-let createString name default doc fulldoc =
- createPrefInternal name default doc fulldoc
+let createString name ?(local=false) default doc fulldoc =
+ createPrefInternal name local default doc fulldoc
(fun v -> [v])
(fun cell -> Uarg.String (fun s -> set cell s))
-let createFspath name default doc fulldoc =
- createPrefInternal name default doc fulldoc
+let createFspath name ?(local=false) default doc fulldoc =
+ createPrefInternal name local default doc fulldoc
(fun v -> [System.fspathToString v])
(fun cell -> Uarg.String (fun s -> set cell (System.fspathFromString s)))
-let createStringList name doc fulldoc =
- createPrefInternal name [] doc fulldoc
+let createStringList name ?(local=false) doc fulldoc =
+ createPrefInternal name local [] doc fulldoc
(fun v -> v)
(fun cell -> Uarg.String (fun s -> set cell (s::(fst !cell))))
Modified: trunk/src/ubase/prefs.mli
===================================================================
--- trunk/src/ubase/prefs.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/ubase/prefs.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -13,6 +13,7 @@
(* accumulates a list of values. *)
val createBool :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> bool (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -20,6 +21,7 @@
val createInt :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> int (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -27,6 +29,7 @@
val createString :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> string (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -34,6 +37,7 @@
val createFspath :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> System.fspath (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
@@ -41,6 +45,7 @@
val createStringList :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
-> string list t (* -> new preference value *)
@@ -51,6 +56,7 @@
(* IllegalValue if it is passed a string it cannot deal with. *)
val create :
string (* preference name *)
+ -> ?local:bool (* whether it is local to the client *)
-> 'a (* initial value *)
-> string (* documentation string *)
-> string (* full (tex) documentation string *)
Modified: trunk/src/uicommon.ml
===================================================================
--- trunk/src/uicommon.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/uicommon.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -441,7 +441,7 @@
let architecture =
Remote.registerRootCmd
"architecture"
- (fun (_,()) -> return (Util.osType = `Win32, Osx.isMacOSX))
+ (fun (_,()) -> return (Util.osType = `Win32, Osx.isMacOSX, Util.isCygwin))
(* During startup the client determines the case sensitivity of each root.
If any root is case insensitive, all roots must know this -- it's
@@ -452,16 +452,19 @@
let checkCaseSensitivity () =
Globals.allRootsMap (fun r -> architecture r ()) >>= (fun archs ->
let someHostIsRunningWindows =
- Safelist.exists (fun (isWin, _) -> isWin) archs in
+ Safelist.exists (fun (isWin, _, _) -> isWin) archs in
let allHostsAreRunningWindows =
- Safelist.for_all (fun (isWin, _) -> isWin) archs in
+ Safelist.for_all (fun (isWin, _, _) -> isWin) archs in
+ let someHostIsRunningBareWindows =
+ Safelist.exists (fun (isWin, _, isCyg) -> isWin && not isCyg) archs in
let someHostRunningOsX =
- Safelist.exists (fun (_, isOSX) -> isOSX) archs in
+ Safelist.exists (fun (_, isOSX, _) -> isOSX) archs in
let someHostIsCaseInsensitive =
someHostIsRunningWindows || someHostRunningOsX in
Case.init someHostIsCaseInsensitive;
Props.init someHostIsRunningWindows;
Osx.init someHostRunningOsX;
+ Fileinfo.init someHostIsRunningBareWindows;
Prefs.set Globals.someHostIsRunningWindows someHostIsRunningWindows;
Prefs.set Globals.allHostsAreRunningWindows allHostsAreRunningWindows;
return ())
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/uigtk2.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -259,7 +259,7 @@
GBin.scrolled_window ?packing ~show:false
~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
in
- let text = GText.view ?editable ?wrap_mode:(Some `WORD) ~packing:sw#add () in
+ let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in
object
inherit GObj.widget_full sw#as_widget
method text = text
@@ -382,8 +382,20 @@
val values = Array.make width 0.
val mutable active = false
- method activate a = active <- a
+ method redraw () =
+ scale := min_scale;
+ while !maxim > !scale do
+ scale := !scale *. 1.5
+ done;
+ pixmap#set_foreground `WHITE;
+ pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
+ pixmap#set_foreground `BLACK;
+ for i = 0 to width - 1 do
+ self#rect i values.(max 0 (i - 1)) values.(i)
+ done
+ method activate a = active <- a; if a then self#redraw ()
+
method scale h = truncate ((float height) *. h /. !scale)
method private rect i v' v =
@@ -416,18 +428,9 @@
if active then begin
let need_resize =
!maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in
- if need_resize then begin
- scale := min_scale;
- while !maxim > !scale do
- scale := !scale *. 1.5
- done;
- pixmap#set_foreground `WHITE;
- pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();
- pixmap#set_foreground `BLACK;
- for i = 0 to width - 1 do
- self#rect i values.(max 0 (i - 1)) values.(i)
- done
- end else begin
+ if need_resize then
+ self#redraw ()
+ else begin
pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap);
pixmap#set_foreground `WHITE;
pixmap#rectangle
@@ -440,7 +443,26 @@
let clientWritten = ref 0.
let serverWritten = ref 0.
+let emitRate2 = ref 0.
+let receiveRate2 = ref 0.
+let rate2str v =
+ if v > 9.9e3 then begin
+ if v > 9.9e6 then
+ Format.sprintf "%1.0f MiB/s" (v /. 1e6)
+ else if v > 999e3 then
+ Format.sprintf "%1.1f MiB/s" (v /. 1e6)
+ else
+ Format.sprintf "%1.0f KiB/s" (v /. 1e3)
+ end else begin
+ if v > 990. then
+ Format.sprintf "%1.1f KiB/s" (v /. 1e3)
+ else if v > 99. then
+ Format.sprintf "%1.2f KiB/s" (v /. 1e3)
+ else
+ " "
+ end
+
let statistics () =
let title = "Statistics" in
let t = GWindow.dialog ~title () in
@@ -487,10 +509,26 @@
let emittedBytes = ref 0. in
let emitRate = ref 0. in
- let emitRate2 = ref 0. in
let receivedBytes = ref 0. in
let receiveRate = ref 0. in
- let receiveRate2 = ref 0. in
+
+ let stopCounter = ref 0 in
+
+ let updateTable () =
+ let kib2str v = Format.sprintf "%.0f B" v in
+ lst#set_cell ~text:(rate2str !receiveRate2) 0 1;
+ lst#set_cell ~text:(rate2str !emitRate2) 0 2;
+ lst#set_cell ~text:
+ (rate2str (!receiveRate2 +. !emitRate2)) 0 3;
+ lst#set_cell ~text:(kib2str !receivedBytes) 1 1;
+ lst#set_cell ~text:(kib2str !emittedBytes) 1 2;
+ lst#set_cell ~text:
+ (kib2str (!receivedBytes +. !emittedBytes)) 1 3;
+ lst#set_cell ~text:(kib2str !clientWritten) 2 1;
+ lst#set_cell ~text:(kib2str !serverWritten) 2 2;
+ lst#set_cell ~text:
+ (kib2str (!clientWritten +. !serverWritten)) 2 3
+ in
let timeout _ =
emitRate :=
a *. !emitRate +.
@@ -508,42 +546,26 @@
reception#push !receiveRate;
emittedBytes := !Remote.emittedBytes;
receivedBytes := !Remote.receivedBytes;
- let kib2str v = Format.sprintf "%.0f B" v in
- let rate2str v =
- if v > 9.9e3 then begin
- if v > 9.9e6 then
- Format.sprintf "%4.0f MiB/s" (v /. 1e6)
- else if v > 999e3 then
- Format.sprintf "%4.1f MiB/s" (v /. 1e6)
- else
- Format.sprintf "%4.0f KiB/s" (v /. 1e3)
- end else begin
- if v > 990. then
- Format.sprintf "%4.1f KiB/s" (v /. 1e3)
- else if v > 99. then
- Format.sprintf "%4.2f KiB/s" (v /. 1e3)
- else
- " "
- end
- in
- lst#set_cell ~text:(rate2str !receiveRate2) 0 1;
- lst#set_cell ~text:(rate2str !emitRate2) 0 2;
- lst#set_cell ~text:
- (rate2str (!receiveRate2 +. !emitRate2)) 0 3;
- lst#set_cell ~text:(kib2str !receivedBytes) 1 1;
- lst#set_cell ~text:(kib2str !emittedBytes) 1 2;
- lst#set_cell ~text:
- (kib2str (!receivedBytes +. !emittedBytes)) 1 3;
- lst#set_cell ~text:(kib2str !clientWritten) 2 1;
- lst#set_cell ~text:(kib2str !serverWritten) 2 2;
- lst#set_cell ~text:
- (kib2str (!clientWritten +. !serverWritten)) 2 3;
- true
+ if !stopCounter > 0 then decr stopCounter;
+ if !stopCounter = 0 then begin
+ emitRate2 := 0.; receiveRate2 := 0.;
+ end;
+ updateTable ();
+ !stopCounter <> 0
in
- ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.)) ~callback:timeout);
+ let startStats () =
+ if !stopCounter = 0 then begin
+ emittedBytes := !Remote.emittedBytes;
+ receivedBytes := !Remote.receivedBytes;
+ stopCounter := -1;
+ ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.))
+ ~callback:timeout)
+ end else
+ stopCounter := -1
+ in
+ let stopStats () = stopCounter := 10 in
+ (t, startStats, stopStats)
- t
-
(****)
(* Standard file dialog *)
@@ -617,13 +639,13 @@
let contCommand() =
result := Some(fileE#text);
t#destroy () in
+ let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in
+ ignore (quitButton#connect#clicked
+ ~callback:(fun () -> result := None; t#destroy()));
let contButton = GButton.button ~stock:`OK ~packing:f3#add () in
ignore (contButton#connect#clicked ~callback:contCommand);
ignore (fileE#connect#activate ~callback:contCommand);
contButton#grab_default ();
- let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in
- ignore (quitButton#connect#clicked
- ~callback:(fun () -> result := None; t#destroy()));
t#show ();
ignore (t#connect#destroy ~callback:GMain.Main.quit);
GMain.Main.main ();
@@ -746,14 +768,14 @@
okBox ~title:"Error" ~typ:`ERROR
~message:"Something's wrong with the values you entered, try again" in
let f3 = t#action_area in
+ let quitButton =
+ GButton.button ~stock:`QUIT ~packing:f3#add () in
+ ignore (quitButton#connect#clicked ~callback:safeExit);
let contButton =
GButton.button ~stock:`OK ~packing:f3#add () in
ignore (contButton#connect#clicked ~callback:contCommand);
contButton#grab_default ();
ignore (fileE#connect#activate ~callback:contCommand);
- let quitButton =
- GButton.button ~stock:`QUIT ~packing:f3#add () in
- ignore (quitButton#connect#clicked ~callback:safeExit);
t#show ();
ignore (t#connect#destroy ~callback:GMain.Main.quit);
@@ -827,7 +849,7 @@
("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
- with int_of_string -> raise (Util.Fatal
+ with Failure "int_of_string" -> raise (Util.Fatal
("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
@@ -969,12 +991,12 @@
close_out ch;
fillLst profile;
exit () in
+ let cancelButton =
+ GButton.button ~stock:`CANCEL ~packing:f3#add () in
+ ignore (cancelButton#connect#clicked ~callback:exit);
let okButton = GButton.button ~stock:`OK ~packing:f3#add () in
ignore (okButton#connect#clicked ~callback:okCommand);
okButton#grab_default ();
- let cancelButton =
- GButton.button ~stock:`CANCEL ~packing:f3#add () in
- ignore (cancelButton#connect#clicked ~callback:exit);
t#show ();
grabFocus t;
@@ -1189,7 +1211,7 @@
Statistic window
*******************************************************************)
- let stat_win = statistics () in
+ let (statWin, startStats, stopStats) = statistics () in
(*******************************************************************
Groups of things that are sensitive to interaction at the same time
@@ -1375,11 +1397,12 @@
| Some (title, details) -> messageBox ~title (transcode details)
in
+ let detailsWindowSW =
+ GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
+ ~shadow_type:`IN ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
+ in
let detailsWindow =
- let sw =
- GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
- ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
- GText.view ~editable:false ~wrap_mode:`NONE ~packing:sw#add ()
+ GText.view ~editable:false ~wrap_mode:`NONE ~packing:detailsWindowSW#add ()
in
detailsWindow#misc#modify_font (Lazy.force fontMonospaceMediumPango);
detailsWindow#misc#set_size_chars ~height:3 ~width:112 ();
@@ -1447,18 +1470,20 @@
detailsWindow#buffer#set_text ""
| Some row ->
makeRowVisible row;
- let details =
+ let (formated, details) =
match !theState.(row).whatHappened with
- None -> Uicommon.details2string !theState.(row).ri " "
- | Some(Util.Succeeded, _) -> Uicommon.details2string !theState.(row).ri " "
- | Some(Util.Failed(s), None) -> s
- | Some(Util.Failed(s), Some resultLog) -> s in
+ None | Some(Util.Succeeded, _) ->
+ (true, Uicommon.details2string !theState.(row).ri " ")
+ | Some(Util.Failed(s), _) ->
+ (false, s)
+ in
let path = Path.toString !theState.(row).ri.path1 in
let txt = transcodeFilename path ^ "\n" ^ transcode details in
let len = String.length txt in
let txt =
if txt.[len - 1] = '\n' then String.sub txt 0 (len - 1) else txt in
- detailsWindow#buffer#set_text txt
+ detailsWindow#buffer#set_text txt;
+ detailsWindow#set_wrap_mode (if formated then `NONE else `WORD)
end;
(* Display text *)
updateButtons () in
@@ -1471,6 +1496,8 @@
let progressBar =
GRange.progress_bar ~packing:(statusHBox#pack ~expand:false) () in
+
+ progressBar#misc#set_size_chars ~height:1 ~width:25 ();
progressBar#set_pulse_step 0.02;
let progressBarPulse = ref false in
@@ -1655,25 +1682,41 @@
let t0 = ref 0. in
let t1 = ref 0. in
let lastFrac = ref 0. in
+ let oldWritten = ref 0. in
+ let writeRate = ref 0. in
let displayGlobalProgress v =
if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
lastFrac := v;
progressBar#set_fraction (max 0. (min 1. (v /. 100.)))
end;
-(*
- let t = Unix.gettimeofday () in
- if t -. !t1 >= 1. then begin
- t1 := t;
- let remTime =
- if v <= 0. then ""
- else if v >= 100. then "00:00 ETA"
- else
+ if v < 0.001 then
+ progressBar#set_text " "
+ else begin
+ let t = Unix.gettimeofday () in
+ let delta = t -. !t1 in
+ if delta >= 0.5 then begin
+ t1 := t;
+ let remTime =
+ if v >= 100. then "00:00 remaining" else
let t = truncate ((!t1 -. !t0) *. (100. -. v) /. v +. 0.5) in
- Format.sprintf "%02d:%02d ETA" (t / 60) (t mod 60)
- in
- progressBar#set_text remTime
+ Format.sprintf "%02d:%02d remaining" (t / 60) (t mod 60)
+ in
+ let written = !clientWritten +. !serverWritten in
+ let b = 0.64 ** delta in
+ writeRate :=
+ b *. !writeRate +.
+ (1. -. b) *. (written -. !oldWritten) /. delta;
+ oldWritten := written;
+ let rate = !writeRate (*!emitRate2 +. !receiveRate2*) in
+ let txt =
+ if rate > 99. then
+ Format.sprintf "%s (%s)" remTime (rate2str rate)
+ else
+ remTime
+ in
+ progressBar#set_text txt
+ end
end
-*)
in
let showGlobalProgress b =
@@ -1690,6 +1733,7 @@
totalBytesToTransfer := b;
totalBytesTransferred := Uutil.Filesize.zero;
t0 := Unix.gettimeofday (); t1 := !t0;
+ writeRate := 0.; oldWritten := !clientWritten +. !serverWritten;
displayGlobalProgress 0.
in
@@ -1784,6 +1828,7 @@
let detectUpdatesAndReconcile () =
grDisactivateAll ();
+ startStats ();
mainWindow#clear();
detailsWindow#buffer#set_text "";
@@ -1824,6 +1869,7 @@
current := None;
displayMain();
progressBarPulse := false; sync_action := None; displayGlobalProgress 0.;
+ stopStats ();
grSet grGo (Array.length !theState > 0);
grSet grRescan true;
if Prefs.read Globals.confirmBigDeletes then begin
@@ -1995,6 +2041,7 @@
end else
actions
in
+ startStats ();
Lwt_unix.run
(let actions = loop 0 [] (fun ri -> not (Common.isDeletion ri)) in
Lwt_util.join actions);
@@ -2004,6 +2051,7 @@
Transport.logFinish ();
Trace.showTimer t;
commitUpdates ();
+ stopStats ();
let failures =
let count =
@@ -2088,7 +2136,7 @@
let reloadProfile () =
match !Prefs.profileName with
None -> ()
- | Some(n) -> loadProfile n in
+ | Some(n) -> grDisactivateAll (); loadProfile n in
let detectCmdName = "Rescan" in
let detectCmd () =
@@ -2177,10 +2225,12 @@
item.bytesTransferred <- Uutil.Filesize.zero;
item.bytesToTransfer <- len;
initGlobalProgress len;
+ startStats ();
Uicommon.showDiffs item.ri
(fun title text ->
messageBox ~title:(transcode title) (transcode text))
Trace.status (Uutil.File.ofLine i);
+ stopStats ();
displayGlobalProgress 0.;
fastRedisplay i)
| None ->
@@ -2453,7 +2503,7 @@
ignore (fileMenu#add_separator ());
ignore (fileMenu#add_item
- ~callback:(fun _ -> stat_win#show ()) "Statistics");
+ ~callback:(fun _ -> statWin#show ()) "Statistics");
ignore (fileMenu#add_separator ());
ignore (fileMenu#add_image_item
@@ -2539,9 +2589,11 @@
createToplevelWindow();
(* Display the ui *)
+(*JV: not useful, as Unison does not handle any signal
ignore (GMain.Timeout.add 500 (fun _ -> true));
(* Hack: this allows signals such as SIGINT to be
handled even when Gtk is waiting for events *)
+*)
GMain.Main.main ()
with
Util.Transient(s) | Util.Fatal(s) -> fatalError s
Modified: trunk/src/uimacbridge.ml
===================================================================
--- trunk/src/uimacbridge.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/uimacbridge.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -261,11 +261,11 @@
let unisonRiToDetails ri =
match ri.whatHappened with
- Some (Util.Failed s) -> (Path.toString ri.ri.path) ^ "\n" ^ s
- | _ -> (Path.toString ri.ri.path) ^ "\n" ^ (Uicommon.details2string ri.ri " ");;
+ Some (Util.Failed s) -> (Path.toString ri.ri.path1) ^ "\n" ^ s
+ | _ -> (Path.toString ri.ri.path1) ^ "\n" ^ (Uicommon.details2string ri.ri " ");;
Callback.register "unisonRiToDetails" unisonRiToDetails;;
-let unisonRiToPath ri = Path.toString ri.ri.path;;
+let unisonRiToPath ri = Path.toString ri.ri.path1;;
Callback.register "unisonRiToPath" unisonRiToPath;;
let rcToString rc =
@@ -410,11 +410,11 @@
Callback.register "unisonSynchronize" unisonSynchronize;;
let unisonIgnorePath si =
- Uicommon.addIgnorePattern (Uicommon.ignorePath si.ri.path);;
+ Uicommon.addIgnorePattern (Uicommon.ignorePath si.ri.path1);;
let unisonIgnoreExt si =
- Uicommon.addIgnorePattern (Uicommon.ignoreExt si.ri.path);;
+ Uicommon.addIgnorePattern (Uicommon.ignoreExt si.ri.path1);;
let unisonIgnoreName si =
- Uicommon.addIgnorePattern (Uicommon.ignoreName si.ri.path);;
+ Uicommon.addIgnorePattern (Uicommon.ignoreName si.ri.path1);;
Callback.register "unisonIgnorePath" unisonIgnorePath;;
Callback.register "unisonIgnoreExt" unisonIgnoreExt;;
Callback.register "unisonIgnoreName" unisonIgnoreName;;
@@ -428,7 +428,7 @@
let num = ref(-1) in
let newI = ref None in
(* FIX: we should actually test whether any prefix is now ignored *)
- let keep s = not (Globals.shouldIgnore s.ri.path) in
+ let keep s = not (Globals.shouldIgnore s.ri.path1) in
for j = 0 to (Array.length !theState - 1) do
let s = !theState.(j) in
if keep s then begin
Modified: trunk/src/uitext.ml
===================================================================
--- trunk/src/uitext.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/uitext.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -798,14 +798,17 @@
synchronizeUntilDone ()
end
-let start _ =
+let start interface =
+ if interface <> Uicommon.Text then
+ Util.msg "This Unison binary only provides the text GUI...\n";
begin try
(* Just to make sure something is there... *)
setWarnPrinterForInitialization();
Uicommon.uiInit
(fun s -> Util.msg "%s\n%s\n" Uicommon.shortUsageMsg s; exit 1)
(fun s -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
- (fun () -> if not (Prefs.read silent)
+ (fun () -> if Prefs.read silent then Prefs.set Trace.terse true;
+ if not (Prefs.read silent)
then Util.msg "%s\n" (Uicommon.contactingServerMsg()))
(fun () -> Some "default")
(fun () -> Util.msg "%s" Uicommon.shortUsageMsg; exit 1)
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/update.ml 2009-07-19 20:07:54 UTC (rev 378)
@@ -1400,15 +1400,15 @@
archive
| `BadEnc ->
let uiChild =
- Error ("The file name is not encoded in Unicode ("
- ^ Path.toString path' ^ ")")
+ Error ("The file name is not encoded in Unicode. (File '"
+ ^ Path.toString path' ^ "')")
in
updates := (nm, uiChild) :: !updates;
archive
| `BadName ->
let uiChild =
- Error ("The name of this Unix file is not allowed in Windows ("
- ^ Path.toString path' ^ ")")
+ Error ("The name of this Unix file is not allowed under Windows. \
+ (File '" ^ Path.toString path' ^ "')")
in
updates := (nm, uiChild) :: !updates;
archive
@@ -1541,7 +1541,10 @@
(* Compute the updates for [path] against archive. Also returns an
archive, which is the old archive with time stamps updated
appropriately (i.e., for those files whose contents remain
- unchanged). *)
+ unchanged). The filenames are also updated to match the filesystem
+ 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 =
match Path.deconstruct path with
None ->
@@ -1557,9 +1560,10 @@
None -> archive
| Some arch -> arch
end,
- ui)
+ ui, here, [])
| Some(name, path') ->
- if not (isDir fspath here) then
+ let info = Fileinfo.get true fspath here in
+ if info.Fileinfo.typ <> `DIRECTORY && info.Fileinfo.typ <> `ABSENT then
let error =
if Path.isEmpty here then
Printf.sprintf
@@ -1572,65 +1576,66 @@
the replicas"
(Path.toString fullpath) (Path.toString here)
in
- (* FIX: We have to fail here (and in other error cases below)
- rather than report an error for this path, which would be
- more user friendly. Indeed, the archive is otherwise
- modified in inconsistent way when the failure occurs only
- on one replica (see at the end of this function).
- A better solution should be not to put the archives in a
- different state, but this is a lot more work. *)
- raise (Util.Transient error)
-(* (archive, Error error) *)
+ (archive, Error error, translatePathLocal fspath fullpath, [])
else
- let children = getChildren fspath here in
let (name', status) =
- try
- Safelist.find (fun (name', _) -> Name.eq name name') children
- with Not_found ->
+ if info.Fileinfo.typ = `ABSENT then
(name, checkFilename name)
+ else
+ let children = getChildren fspath here in
+ try
+ Safelist.find (fun (name', _) -> Name.eq name name') children
+ with Not_found ->
+ (name, checkFilename name)
in
match status with
- | `BadEnc ->
+ | `BadEnc ->
raise (Util.Transient
- ("The path " ^ Path.toString fullpath ^
- " is not encoded in Unicode"))
- | `BadName ->
+ (Format.sprintf
+ "The filename %s in path %s is not encoded in Unicode"
+ (Name.toString name) (Path.toString fullpath)))
+ | `BadName ->
raise (Util.Transient
- ("The path " ^ Path.toString fullpath ^
- " is not allowed in Windows"))
+ (Format.sprintf
+ "The filename %s in path %s is not allowed under Windows"
+ (Name.toString name) (Path.toString fullpath)))
| `Dup ->
raise (Util.Transient
- ("The path " ^ Path.toString fullpath ^
- " is ambiguous (i.e., the name of this path or one of its "
- ^ "ancestors is the same, modulo capitalization, as another "
- ^ "path in a case-sensitive filesystem, and you are "
- ^ "synchronizing this filesystem with a case-insensitive "
- ^ "filesystem. "))
+ (Format.sprintf
+ "The path %s is ambiguous at filename %s (i.e., the name \
+ of this path is the same, modulo capitalization, as \
+ another path in a case-sensitive filesystem, and you are \
+ synchronizing this filesystem with a case-insensitive \
+ filesystem."
+ (Path.toString fullpath) (Name.toString name)))
| `Ok ->
- let (desc, child, otherChildren) =
- match archive with
- ArchiveDir (desc, children) ->
- begin try
- let child = NameMap.find name children in
- (desc, child, NameMap.remove name children)
- with Not_found ->
- (desc, NoArchive, children)
- end
- | _ ->
- (Props.dummy, NoArchive, NameMap.empty)
- in
- let (arch, updates) =
- buildUpdate
- child fspath fullpath (Path.child here name') path' dirStamp
- in
- (* We need to put a directory in the archive here for path
- translation. This is fine because we check that there
- really is a directory on both replica.
- Note that we may also put NoArchive deep inside an
- archive...
- *)
- (ArchiveDir (desc, NameMap.add name' arch otherChildren),
- updates)
+ match archive with
+ ArchiveDir (desc, children) ->
+ let archChild =
+ try NameMap.find name children with Not_found -> NoArchive in
+ let otherChildren = NameMap.remove name children in
+ let (arch, updates, localPath, props) =
+ buildUpdate
+ archChild fspath fullpath (Path.child here name') path'
+ dirStamp
+ in
+ let children =
+ if arch = NoArchive then otherChildren else
+ NameMap.add name' arch otherChildren
+ in
+ (ArchiveDir (desc, children), updates, localPath,
+ if info.Fileinfo.typ = `ABSENT then [] else
+ info.Fileinfo.desc :: props)
+ | _ ->
+ let (arch, updates, localPath, props) =
+ buildUpdate
+ NoArchive fspath fullpath (Path.child here name') path'
+ dirStamp
+ in
+ assert (arch = NoArchive);
+ (archive, updates, localPath,
+ if info.Fileinfo.typ = `ABSENT then [] else
+ info.Fileinfo.desc :: props)
(* All the predicates that may change the set of files scanned during
update detection *)
@@ -1675,7 +1680,8 @@
(* for the given path, find the archive and compute the list of update
items; as a side effect, update the local archive w.r.t. time-stamps for
unchanged files *)
-let findLocal fspath pathList: Common.updateItem list =
+let findLocal fspath pathList:
+ (Path.local * Common.updateItem * Props.t list) list =
debug (fun() -> Util.msg "findLocal %s\n" (Fspath.toDebugString fspath));
addHashToTempNames fspath;
(* Maybe we should remember the device number where the root lives at
@@ -1694,12 +1700,12 @@
Safelist.fold_right
(fun path (arch, upd) ->
if Globals.shouldIgnore path then
- (arch, NoUpdates :: upd)
+ (arch, (translatePathLocal fspath path, NoUpdates, []) :: upd)
else
- let (arch', ui) =
+ let (arch', ui, localPath, props) =
buildUpdate arch fspath path Path.empty path dirStamp
in
- arch', ui :: upd)
+ arch', (localPath, ui, props) :: upd)
pathList (archive, [])
in
(*
@@ -1732,8 +1738,7 @@
let t = Trace.startTimer "Collecting changes" in
Globals.allRootsMapWithWaitingAction (fun r ->
debug (fun() -> Util.msg "findOnRoot %s\n" (root2string r));
- findOnRoot r pathList >>= fun updates ->
- Lwt.return (List.combine pathList updates))
+ findOnRoot r pathList)
(fun (host, _) ->
begin match host with
Remote _ -> Uutil.showUpdateStatus "";
@@ -1746,8 +1751,8 @@
Safelist.map
(fun r ->
match r with
- [(p1, u1); (p2, u2)] -> (p1,u1,p2,u2)
- | _ -> assert false)
+ [i1; i2] -> (i1, i2)
+ | _ -> assert false)
(Safelist.transpose updates)
in
Trace.status "";
@@ -2230,3 +2235,9 @@
f fspath path fp
| _ ->
()
+
+(* Hook for filesystem auto-detection (not implemented yet) *)
+let inspectFilesystem =
+ Remote.registerRootCmd
+ "inspectFilesystem"
+ (fun _ -> Lwt.return Proplist.empty)
Modified: trunk/src/update.mli
===================================================================
--- trunk/src/update.mli 2009-07-17 21:41:58 UTC (rev 377)
+++ trunk/src/update.mli 2009-07-19 20:07:54 UTC (rev 378)
@@ -20,7 +20,8 @@
(* Structures describing dirty files/dirs (1 per path given in the -path preference) *)
val findUpdates :
- unit -> (Path.t * Common.updateItem * Path.t * Common.updateItem) list
+ unit -> ((Path.local * Common.updateItem * Props.t list) *
+ (Path.local * Common.updateItem * Props.t list)) list
(* Take a tree of equal update contents and update the archive accordingly. *)
val markEqual :
More information about the Unison-hackers
mailing list