[Unison-hackers] [unison-svn] r473 - trunk/src
bcpierce at seas.upenn.edu
bcpierce at seas.upenn.edu
Sat Apr 16 16:39:33 EDT 2011
Author: bcpierce
Date: 2011-04-16 16:39:33 -0400 (Sat, 16 Apr 2011)
New Revision: 473
Modified:
trunk/src/Makefile
trunk/src/Makefile.OCaml
trunk/src/RECENTNEWS
trunk/src/copy.ml
trunk/src/copy.mli
trunk/src/files.ml
trunk/src/fingerprint.ml
trunk/src/fpcache.ml
trunk/src/mkProjectInfo.ml
trunk/src/os.ml
trunk/src/os.mli
trunk/src/uigtk2.ml
trunk/src/update.ml
Log:
* Small patch from Stephane Glondu to make Unison compile with Ocaml 3.12.
* New version of uigtk2.ml from Matt Zagrabelny that reorganizes the
icons in a slightly more intuitive way.
* Finished implementing the "fastercheckUNSAFE" option, which can be
used (with care!) to achieve *much* faster update detection when all
the common files in the two replicas are known to be identical. See
the documentation for more information.
This feature should still be considered experimental, but it's ready
for other people to try out.
Modified: trunk/src/Makefile
===================================================================
--- trunk/src/Makefile 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/Makefile 2011-04-16 20:39:33 UTC (rev 473)
@@ -211,7 +211,7 @@
# For developers
runtest:
$(MAKE) NATIVE=false DEBUG=true text
- bash ./unison test
+ ./unison test
repeattest:
$(MAKE) all NATIVE=false DEBUG=true UISTYLE=text
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/Makefile.OCaml 2011-04-16 20:39:33 UTC (rev 473)
@@ -53,7 +53,9 @@
# get rid of it...
# OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | sed -e 's/\\/\//g' | sed -e 's///g')
# Better(?) version, June 2005:
-OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | sed -e 's/\\/\//g' | tr -d '\r')
+# OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | sed -e 's/\\/\//g' | tr -d '\r')
+# Another try, Feb 2011, suggested by Ron Isaacson
+OCAMLLIBDIR=$(shell ocamlc -v | tail -1 | sed -e 's/.* //g' | tr '\\' '/' | tr -d '\r')
## BCP (6/05) an alternative, but not quite working, version
## suggested by Nick Montfort:
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/RECENTNEWS 2011-04-16 20:39:33 UTC (rev 473)
@@ -1,5 +1,26 @@
+CHANGES FROM VERSION 2.44.0
+
+* Small patch from Stephane Glondu to make Unison compile with Ocaml 3.12.
+
+* New version of uigtk2.ml from Matt Zagrabelny that reorganizes the
+ icons in a slightly more intuitive way.
+
+* Finished implementing the "fastercheckUNSAFE" option, which can be
+ used (with care!) to achieve *much* faster update detection when all
+ the common files in the two replicas are known to be identical. See
+ the documentation for more information.
+
+ This feature should still be considered experimental, but it's ready
+ for other people to try out.
+
+-------------------------------
CHANGES FROM VERSION 2.43.12
+* Small patch from Stephane Glondu to make Unison compile with Ocaml 3.12.
+
+* New version of uigtk2.ml from Matt Zagrabelny that reorganizes the
+ icons in a slightly more intuitive way.
+
* Incorporated new version of fsmonitor.py from Christophe Gohle
-------------------------------
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/copy.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -42,65 +42,79 @@
(****)
-(* Check whether the source file has been modified during synchronization *)
-let checkContentsChangeLocal
- fspathFrom pathFrom archDesc archDig archStamp archRess paranoid =
- let info = Fileinfo.get true fspathFrom pathFrom in
- let clearlyModified =
- info.Fileinfo.typ <> `FILE
- || Props.length info.Fileinfo.desc <> Props.length archDesc
- || Osx.ressLength info.Fileinfo.osX.Osx.ressInfo <>
- Osx.ressLength archRess
- in
- let dataClearlyUnchanged =
- not clearlyModified
- && Props.same_time info.Fileinfo.desc archDesc
- && not (Fpcache.excelFile pathFrom)
- && match archStamp with
- Some (Fileinfo.InodeStamp inode) -> info.Fileinfo.inode = inode
- | Some (Fileinfo.CtimeStamp ctime) -> true
- | None -> false
- in
- let ressClearlyUnchanged =
- not clearlyModified
- && Osx.ressUnchanged archRess info.Fileinfo.osX.Osx.ressInfo
- None dataClearlyUnchanged
- in
- if dataClearlyUnchanged && ressClearlyUnchanged then begin
- if paranoid && not (Os.isPseudoFingerprint archDig) then begin
- let newDig = Os.fingerprint fspathFrom pathFrom info in
- if archDig <> newDig then begin
- Update.markPossiblyUpdated fspathFrom pathFrom;
+(* If newFpOpt = Some newfp, check that the current source contents
+ matches newfp. Otherwise, check whether the source file has been
+ modified during synchronization. *)
+let checkForChangesToSourceLocal
+ fspathFrom pathFrom archDesc archFp archStamp archRess newFpOpt paranoid =
+ (* Retrieve attributes of current source file *)
+ let sourceInfo = Fileinfo.get true fspathFrom pathFrom in
+ match newFpOpt with
+ None ->
+ (* no newfp provided: so we need to compare the archive with the
+ current source *)
+ let clearlyChanged =
+ sourceInfo.Fileinfo.typ <> `FILE
+ || Props.length sourceInfo.Fileinfo.desc <> Props.length archDesc
+ || Osx.ressLength sourceInfo.Fileinfo.osX.Osx.ressInfo <>
+ Osx.ressLength archRess in
+ let dataClearlyUnchanged =
+ not clearlyChanged
+ && Props.same_time sourceInfo.Fileinfo.desc archDesc
+ && not (Fpcache.excelFile pathFrom)
+ && match archStamp with
+ Some (Fileinfo.InodeStamp inode) -> sourceInfo.Fileinfo.inode = inode
+ | Some (Fileinfo.CtimeStamp ctime) -> true
+ | None -> false in
+ let ressClearlyUnchanged =
+ not clearlyChanged
+ && Osx.ressUnchanged archRess sourceInfo.Fileinfo.osX.Osx.ressInfo
+ None dataClearlyUnchanged in
+ if dataClearlyUnchanged && ressClearlyUnchanged then begin
+ if paranoid && not (Os.isPseudoFingerprint archFp) then begin
+ let newFp = Os.fingerprint fspathFrom pathFrom sourceInfo in
+ if archFp <> newFp then begin
+ Update.markPossiblyUpdated fspathFrom pathFrom;
+ raise (Util.Transient (Printf.sprintf
+ "The source file %s\n\
+ has been modified but the fast update detection mechanism\n\
+ failed to detect it. Try running once with the fastcheck\n\
+ option set to 'no'."
+ (Fspath.toPrintString (Fspath.concat fspathFrom pathFrom))))
+ end
+ end
+ end else if
+ clearlyChanged
+ || archFp <> Os.fingerprint fspathFrom pathFrom sourceInfo
+ then
raise (Util.Transient (Printf.sprintf
- "The source file %s\n\
- has been modified but the fast update detection mechanism\n\
- failed to detect it. Try running once with the fastcheck\n\
- option set to 'no'."
+ "The source file %s\nhas been modified during synchronization. \
+ Transfer aborted."
(Fspath.toPrintString (Fspath.concat fspathFrom pathFrom))))
- end
- end
- end else if
- clearlyModified
- || archDig <> Os.fingerprint fspathFrom pathFrom info
- then
- raise (Util.Transient (Printf.sprintf
- "The source file %s\nhas been modified during synchronization. \
- Transfer aborted."
- (Fspath.toPrintString (Fspath.concat fspathFrom pathFrom))))
+ | Some newfp ->
+ (* newfp provided means that the archive contains a pseudo-fingerprint... *)
+ assert (Os.isPseudoFingerprint archFp);
+ (* ... so we can't compare the archive with the source; instead we
+ need to compare the current source to the new fingerprint: *)
+ if newfp <> Os.fingerprint fspathFrom pathFrom sourceInfo then
+ raise (Util.Transient (Printf.sprintf
+ "Current source file %s\n not same as transferred file. \
+ Transfer aborted."
+ (Fspath.toPrintString (Fspath.concat fspathFrom pathFrom))))
-let checkContentsChangeOnRoot =
+let checkForChangesToSourceOnRoot =
Remote.registerRootCmd
- "checkContentsChange"
+ "checkForChangesToSource"
(fun (fspathFrom,
- (pathFrom, archDesc, archDig, archStamp, archRess, paranoid)) ->
- checkContentsChangeLocal
- fspathFrom pathFrom archDesc archDig archStamp archRess paranoid;
+ (pathFrom, archDesc, archFp, archStamp, archRess, newFpOpt, paranoid)) ->
+ checkForChangesToSourceLocal
+ fspathFrom pathFrom archDesc archFp archStamp archRess newFpOpt paranoid;
Lwt.return ())
-let checkContentsChange
- root pathFrom archDesc archDig archStamp archRess paranoid =
- checkContentsChangeOnRoot
- root (pathFrom, archDesc, archDig, archStamp, archRess, paranoid)
+let checkForChangesToSource
+ root pathFrom archDesc archFp archStamp archRess newFpOpt paranoid =
+ checkForChangesToSourceOnRoot
+ root (pathFrom, archDesc, archFp, archStamp, archRess, newFpOpt, paranoid)
(****)
@@ -156,18 +170,27 @@
Lwt.return None
type transferStatus =
- Success of Fileinfo.t
- | Failure of string
+ TransferSucceeded of Fileinfo.t
+ | TransferNeedsDoubleCheckAgainstCurrentSource of Fileinfo.t * Os.fullfingerprint
+ | TransferFailed of string
-(* Paranoid check: recompute the transferred file's digest to match it
- with the archive's *)
+(* Paranoid check: recompute the transferred file's fingerprint to match it
+ with the archive's. If the old
+ fingerprint was a pseudo-fingerprint, we can't tell just from looking at the
+ new file and the archive information, so we return
+ TransferProbablySucceeded in this case, along with the new fingerprint
+ that we can check in checkForChangesToSource when we've
+ calculated the current source fingerprint.
+ *)
let paranoidCheck fspathTo pathTo realPathTo desc fp ress =
let info = Fileinfo.get false fspathTo pathTo in
let fp' = Os.fingerprint fspathTo pathTo info in
- if fp' <> fp (* && not (Os.isPseudoFingerprint fp) *) then begin
- Lwt.return (Failure (Os.reasonForFingerprintMismatch fp fp'))
+ if Os.isPseudoFingerprint fp then begin
+ Lwt.return (TransferNeedsDoubleCheckAgainstCurrentSource (info,fp'))
+ end else if fp' <> fp then begin
+ Lwt.return (TransferFailed (Os.reasonForFingerprintMismatch fp fp'))
end else
- Lwt.return (Success info)
+ Lwt.return (TransferSucceeded info)
let saveTempFileLocal (fspathTo, (pathTo, realPathTo, reason)) =
let savepath =
@@ -833,7 +856,7 @@
Uutil.showProgress id len "alr";
setFileinfo fspathTo pathTo realPathTo update desc;
Xferhint.insertEntry fspathTo pathTo fp;
- Lwt.return (`DONE (Success tempInfo, Some msg))
+ Lwt.return (`DONE (TransferSucceeded tempInfo, Some msg))
end else
registerFileTransfer pathTo fp
(fun () ->
@@ -843,7 +866,7 @@
Some (info, msg) ->
(* Transfer was performed by copying *)
Xferhint.insertEntry fspathTo pathTo fp;
- Lwt.return (`DONE (Success info, Some msg))
+ Lwt.return (`DONE (TransferSucceeded info, Some msg))
| None ->
if shouldUseExternalCopyprog update desc then
Lwt.return (`EXTERNAL (prepareExternalTransfer fspathTo pathTo))
@@ -863,10 +886,11 @@
let transferFileReg = Lwt_util.make_region 440
let bufferSize sz =
- min 64 ((truncate (Uutil.Filesize.toFloat sz) + 1023) / 1024)
(* Token queue *)
- +
- 8 (* Read buffer *)
+ min 64 ((truncate (Uutil.Filesize.toFloat sz) + 1023) / 1024)
+ +
+ (* Read buffer *)
+ 8
let transferFile
rootFrom pathFrom rootTo fspathTo pathTo realPathTo
@@ -930,14 +954,23 @@
end >>= fun status ->
Trace.showTimer timer;
match status with
- Success info ->
- checkContentsChange rootFrom pathFrom desc fp stamp ress false
+ TransferSucceeded info ->
+ checkForChangesToSource rootFrom pathFrom desc fp stamp ress None false
>>= fun () ->
Lwt.return info
- | Failure reason ->
+ | TransferNeedsDoubleCheckAgainstCurrentSource (info,newfp) ->
+ debug (fun() -> Util.msg
+ "Archive data for %s is a pseudo-fingerprint: double-checking...\n"
+ (Path.toString realPathTo));
+
+ checkForChangesToSource rootFrom pathFrom
+ desc fp stamp ress (Some newfp) false
+ >>= (fun () ->
+ Lwt.return info)
+ | TransferFailed reason ->
(* Maybe we failed because the source file was modified.
We check this before reporting a failure *)
- checkContentsChange rootFrom pathFrom desc fp stamp ress true
+ checkForChangesToSource rootFrom pathFrom desc fp stamp ress None true
>>= fun () ->
- (* This function always fails! *)
+ (* This function never returns (it is supposed to fail) *)
saveTempFileOnRoot rootTo (pathTo, realPathTo, reason)
Modified: trunk/src/copy.mli
===================================================================
--- trunk/src/copy.mli 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/copy.mli 2011-04-16 20:39:33 UTC (rev 473)
@@ -1,17 +1,16 @@
-(* Transfer a file from a replica to the other *)
+(* Transfer a file from one replica to the other *)
val file :
Common.root (* root of source *)
-> Path.local (* path of source *)
-> Common.root (* root of target *)
-> Fspath.t (* fspath of target *)
- -> Path.local (* path of target *)
- -> Path.local (* path of "real" [original] target *)
+ -> Path.local (* path of target (temp location) *)
+ -> Path.local (* path of "real" (original) target *)
-> [`Update of (Uutil.Filesize.t * Uutil.Filesize.t) | `Copy]
-> Props.t (* permissions for new file *)
-> Os.fullfingerprint (* fingerprint of file *)
- -> Fileinfo.stamp option
- (* source file stamp, if available *)
+ -> Fileinfo.stamp option (* source file stamp, if available *)
-> Osx.ressStamp (* ressource info of file *)
-> Uutil.File.t (* file's index in UI (for progress bars) *)
-> Fileinfo.t Lwt.t (* information regarding the transferred file *)
@@ -25,5 +24,5 @@
-> [`Update of (Uutil.Filesize.t * Uutil.Filesize.t) | `Copy]
-> Props.t (* permissions for new file *)
-> Uutil.Filesize.t (* fork length *)
- -> Uutil.File.t option (* file's index in UI (for progress bars), as appropriate *)
+ -> Uutil.File.t option (* file's index in UI (for progress bars), if appropriate *)
-> unit
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/files.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -471,19 +471,19 @@
Lwt.catch
(fun () ->
match f with
- Update.ArchiveFile (desc, dig, stamp, ress) ->
+ Update.ArchiveFile (desc, fp, stamp, ress) ->
Lwt_util.run_in_region copyReg 1 (fun () ->
Abort.check id;
let stmp =
if Update.useFastChecking () then Some stamp else None in
Copy.file
rootFrom pFrom rootTo workingDir pTo realPTo
- update desc dig stmp ress id
+ update desc fp stmp ress id
>>= fun info ->
let ress' = Osx.stamp info.Fileinfo.osX in
Lwt.return
(Update.ArchiveFile (Props.override info.Fileinfo.desc desc,
- dig, Fileinfo.stamp info, ress'),
+ fp, Fileinfo.stamp info, ress'),
[]))
| Update.ArchiveSymlink l ->
Lwt_util.run_in_region copyReg 1 (fun () ->
@@ -822,14 +822,14 @@
(* retrieve the archive for this file, if any *)
let arch =
match ui1, ui2 with
- | Updates (_, Previous (_,_,dig,_)), Updates (_, Previous (_,_,dig2,_)) ->
- if dig = dig2 then
- Stasher.getRecentVersion fspath1 localPath1 dig
+ | Updates (_, Previous (_,_,fp,_)), Updates (_, Previous (_,_,fp2,_)) ->
+ if fp = fp2 then
+ Stasher.getRecentVersion fspath1 localPath1 fp
else
assert false
- | NoUpdates, Updates(_, Previous (_,_,dig,_))
- | Updates(_, Previous (_,_,dig,_)), NoUpdates ->
- Stasher.getRecentVersion fspath1 localPath1 dig
+ | NoUpdates, Updates(_, Previous (_,_,fp,_))
+ | Updates(_, Previous (_,_,fp,_)), NoUpdates ->
+ Stasher.getRecentVersion fspath1 localPath1 fp
| Updates (_, New), Updates(_, New)
| Updates (_, New), NoUpdates
| NoUpdates, Updates (_, New) ->
@@ -860,9 +860,9 @@
Os.delete workingDirForMerge newarch;
let info1 = Fileinfo.get false workingDirForMerge working1 in
(* FIX: Why split out the parts of the pair? Why is it not abstract anyway??? *)
- let dig1 = Os.fingerprint workingDirForMerge working1 info1 in
+ let fp1 = Os.fingerprint workingDirForMerge working1 info1 in
let info2 = Fileinfo.get false workingDirForMerge working2 in
- let dig2 = Os.fingerprint workingDirForMerge working2 info2 in
+ let fp2 = Os.fingerprint workingDirForMerge working2 info2 in
let cmd = formatMergeCmd
path1
(Fspath.quotes (Fspath.concat workingDirForMerge working1))
@@ -910,9 +910,9 @@
say (fun () -> Util.msg "Two outputs detected \n");
let info1 = Fileinfo.get false workingDirForMerge new1 in
let info2 = Fileinfo.get false workingDirForMerge new2 in
- let dig1' = Os.fingerprint workingDirForMerge new1 info1 in
- let dig2' = Os.fingerprint workingDirForMerge new2 info2 in
- if dig1'=dig2' then begin
+ let fp1' = Os.fingerprint workingDirForMerge new1 info1 in
+ let fp2' = Os.fingerprint workingDirForMerge new2 info2 in
+ if fp1'=fp2' then begin
debug (fun () -> Util.msg "Two outputs equal => update the archive\n");
copy [(new1,working1); (new2,working2); (new1,workingarch)];
end else
@@ -950,18 +950,18 @@
if working1_still_exists && working2_still_exists then begin
say (fun () -> Util.msg "No output from merge cmd and both original files are still present\n");
let info1' = Fileinfo.get false workingDirForMerge working1 in
- let dig1' = Os.fingerprint workingDirForMerge working1 info1' in
+ let fp1' = Os.fingerprint workingDirForMerge working1 info1' in
let info2' = Fileinfo.get false workingDirForMerge working2 in
- let dig2' = Os.fingerprint workingDirForMerge working2 info2' in
- if dig1 = dig1' && dig2 = dig2' then
+ let fp2' = Os.fingerprint workingDirForMerge working2 info2' in
+ if fp1 = fp1' && fp2 = fp2' then
raise (Util.Transient "Merge program didn't change either temp file");
- if dig1' = dig2' then begin
+ if fp1' = fp2' then begin
say (fun () -> Util.msg "Merge program made files equal\n");
copy [(working1,workingarch)];
- end else if dig2 = dig2' then begin
+ end else if fp2 = fp2' then begin
say (fun () -> Util.msg "Merge program changed just first input\n");
copy [(working1,working2);(working1,workingarch)]
- end else if dig1 = dig1' then begin
+ end else if fp1 = fp1' then begin
say (fun () -> Util.msg "Merge program changed just second input\n");
copy [(working2,working1);(working2,workingarch)]
end else
@@ -1016,11 +1016,11 @@
Util.msg "Warning: 'backupcurrent' is not set for path %s\n" (Path.toString path1);
Stasher.stashCurrentVersion workingDirForMerge localPath1 (Some workingarch);
let infoarch = Fileinfo.get false workingDirForMerge workingarch in
- let dig = Os.fingerprint arch_fspath Path.empty infoarch in
- debug (fun () -> Util.msg "New digest is %s\n" (Os.fullfingerprint_to_string dig));
+ let fp = Os.fingerprint arch_fspath Path.empty infoarch in
+ debug (fun () -> Util.msg "New fingerprint is %s\n" (Os.fullfingerprint_to_string fp));
let new_archive_entry =
Update.ArchiveFile
- (Props.get (Fs.stat arch_fspath) infoarch.osX, dig,
+ (Props.get (Fs.stat arch_fspath) infoarch.osX, fp,
Fileinfo.stamp (Fileinfo.get true arch_fspath Path.empty),
Osx.stamp infoarch.osX) in
Update.replaceArchive root1 path1 new_archive_entry >>= fun _ ->
Modified: trunk/src/fingerprint.ml
===================================================================
--- trunk/src/fingerprint.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/fingerprint.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -22,7 +22,7 @@
let pseudo_prefix = "LEN"
let pseudo path len = pseudo_prefix ^ (Uutil.Filesize.toString len) ^ "@" ^
- (Path.toString path)
+ (Digest.string (Path.toString path))
let ispseudo f = Util.startswith f pseudo_prefix
Modified: trunk/src/fpcache.ml
===================================================================
--- trunk/src/fpcache.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/fpcache.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -235,10 +235,42 @@
in
du && ressClearlyUnchanged fastCheck newInfo oldRess du
-let fingerprint ?(newfile=false) fastCheck currfspath path info optDig =
+let fastercheckUNSAFE =
+ Prefs.createBool "fastercheckUNSAFE"
+ false "!skip computing fingerprints for new files (experts only!)"
+ ( "THIS FEATURE IS STILL EXPERIMENTAL AND SHOULD BE USED WITH EXTREME CAUTION. "
+ ^ "\n\n"
+ ^ "When this flag is set to {\\tt true}, Unison will compute a 'pseudo-"
+ ^ "fingerprint' the first time it sees a file (either because the file is "
+ ^ "new or because Unison is running for the first time). This enormously "
+ ^ "speeds update detection, but it must be used with care, as it can cause "
+ ^ "Unison to miss conflicts: If "
+ ^ "a given path in the filesystem contains files on {\\em both} sides that "
+ ^ "Unison has not yet seen, and if those files have the same length but different "
+ ^ "contents, then Unison will not notice the presence of a conflict. If, later, one "
+ ^ "of the files is changed, the changed file will be propagated, overwriting "
+ ^ "the other. "
+ ^ "\n\n"
+ ^ "Moreover, even when the files are initially identical, setting this flag can lead "
+ ^ "to potentially confusing behavior: "
+ ^ "if a newly created file is later touched without being modified, Unison will "
+ ^ "treat this "
+ ^ "conservatively as a potential change (since it has no record of the earlier "
+ ^ "contents) and show it as needing to be propagated to the other replica. "
+ ^ "\n\n"
+ ^ "Most users should leave this flag off -- the small time savings of not "
+ ^ "fingerprinting new files is not worth the cost in terms of safety. However, "
+ ^ "it can be very useful for power users with huge replicas that are known to "
+ ^ "be already synchronized (e.g., because one replica is a newly created duplicate "
+ ^ "of the other, or because they have previously been synchronized with Unison but "
+ ^ "Unison's archives need to be rebuilt). In such situations, it is recommended "
+ ^ "that this flag be set only for the initial run of Unison, so that new archives "
+ ^ "can be created quickly, and then turned off for normal use.")
+
+let fingerprint ?(newfile=false) fastCheck currfspath path info optFp =
let res =
try
- let (cachedDesc, cachedDig, cachedStamp, cachedRess) =
+ let (cachedDesc, cachedFp, cachedStamp, cachedRess) =
PathTbl.find tbl (Path.toString path) in
if
not (clearlyUnchanged
@@ -247,14 +279,21 @@
raise Not_found;
debug (fun () -> Util.msg "cache hit for path %s\n"
(Path.toDebugString path));
- (info.Fileinfo.desc, cachedDig, Fileinfo.stamp info,
+ (info.Fileinfo.desc, cachedFp, Fileinfo.stamp info,
Fileinfo.ressStamp info)
with Not_found ->
if fastCheck then
debug (fun () -> Util.msg "cache miss for path %s\n"
(Path.toDebugString path));
let (info, dig) =
- Os.safeFingerprint ~newfile currfspath path info optDig in
+ if Prefs.read fastercheckUNSAFE && newfile then begin
+ debug (fun()-> Util.msg "skipping initial fingerprint of %s\n"
+ (Fspath.toDebugString (Fspath.concat currfspath path)));
+ (Fileinfo.get false currfspath path,
+ Os.pseudoFingerprint path (Props.length info.Fileinfo.desc))
+ end else begin
+ Os.safeFingerprint currfspath path info optFp
+ end in
(info.Fileinfo.desc, dig, Fileinfo.stamp info, Fileinfo.ressStamp info)
in
save path res;
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/mkProjectInfo.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -5,8 +5,8 @@
let projectName = "unison"
let majorVersion = 2
-let minorVersion = 43
-let pointVersionOrigin = 455 (* Revision that corresponds to point version 0 *)
+let minorVersion = 44
+let pointVersionOrigin = 471 (* Revision that corresponds to point version 0 *)
(* Documentation:
This is a program to construct a version of the form Major.Minor.Point,
@@ -55,3 +55,4 @@
+
Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/os.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -224,38 +224,6 @@
(Fingerprint.file fspath path,
Osx.ressFingerprint fspath path info.Fileinfo.osX)
-let fastercheckUNSAFE =
- Prefs.createBool "fastercheckUNSAFE"
- false "!skip computing fingerprints for new files (experts only!)"
- ( "THIS FEATURE IS STILL EXPERIMENTAL AND SHOULD BE USED WITH EXTREME CAUTION. "
- ^ "\n\n"
- ^ "When this flag is set to {\\tt true}, Unison will compute a 'pseudo-"
- ^ "fingerprint' the first time it sees a file (either because the file is "
- ^ "new or because Unison is running for the first time). This enormously "
- ^ "speeds update detection, but it must be used with care, as it can cause "
- ^ "Unison to miss conflicts: If "
- ^ "a given path in the filesystem contains files on {\\em both} sides that "
- ^ "Unison has not yet seen, and if those files have the same length but different "
- ^ "contents, then Unison will not notice the presence of a conflict. If, later, one "
- ^ "of the files is changed, the changed file will be propagated, overwriting "
- ^ "the other. "
- ^ "\n\n"
- ^ "Moreover, even when the files are initially identical, setting this flag can lead "
- ^ "to potentially confusing behavior: "
- ^ "if a newly created file is later touched without being modified, Unison will "
- ^ "treat this "
- ^ "conservatively as a potential change (since it has no record of the earlier "
- ^ "contents) and show it as needing to be propagated to the other replica. "
- ^ "\n\n"
- ^ "Most users should leave this flag off -- the small time savings of not "
- ^ "fingerprinting new files is not worth the cost in terms of safety. However, "
- ^ "it can be very useful for power users with huge replicas that are known to "
- ^ "be already synchronized (e.g., because one replica is a newly created duplicate "
- ^ "of the other, or because they have previously been synchronized with Unison but "
- ^ "Unison's archives need to be rebuilt). In such situations, it is recommended "
- ^ "that this flag be set only for the initial run of Unison, so that new archives "
- ^ "can be created quickly, and then turned off for normal use.")
-
let pseudoFingerprint path size =
(Fingerprint.pseudo path size, Fingerprint.dummy)
@@ -264,14 +232,8 @@
(* FIX: not completely safe under Unix *)
(* (with networked file system such as NFS) *)
-let safeFingerprint ?(newfile=false) fspath path info optDig =
- if Prefs.read fastercheckUNSAFE && newfile then begin
- debug (fun()-> Util.msg "skipping initial fingerprint of %s\n"
- (Fspath.toDebugString (Fspath.concat fspath path)));
- let info = Fileinfo.get false fspath path in
- (info, pseudoFingerprint path (Props.length info.Fileinfo.desc))
- end else
- let rec retryLoop count info optDig optRessDig =
+let safeFingerprint fspath path info optFp =
+ let rec retryLoop count info optFp optRessFp =
if count = 0 then
raise (Util.Transient
(Printf.sprintf
@@ -279,35 +241,35 @@
the file keeps on changing"
(Fspath.toPrintString (Fspath.concat fspath path))))
else
- let dig =
- match optDig with
+ let fp =
+ match optFp with
None -> Fingerprint.file fspath path
- | Some dig -> dig
+ | Some fp -> fp
in
- let ressDig =
- match optRessDig with
+ let ressFp =
+ match optRessFp with
None -> Osx.ressFingerprint fspath path info.Fileinfo.osX
| Some ress -> ress
in
let (info', dataUnchanged, ressUnchanged) =
Fileinfo.unchanged fspath path info in
if dataUnchanged && ressUnchanged then
- (info', (dig, ressDig))
+ (info', (fp, ressFp))
else
retryLoop (count - 1) info'
- (if dataUnchanged then Some dig else None)
- (if ressUnchanged then Some ressDig else None)
+ (if dataUnchanged then Some fp else None)
+ (if ressUnchanged then Some ressFp else None)
in
retryLoop 10 info (* Maximum retries: 10 times *)
- (match optDig with None -> None | Some (d, _) -> Some d)
+ (match optFp with None -> None | Some (d, _) -> Some d)
None
let fullfingerprint_to_string (fp,rfp) =
Printf.sprintf "(%s,%s)" (Fingerprint.toString fp) (Fingerprint.toString rfp)
-let reasonForFingerprintMismatch (digdata,digress) (digdata',digress') =
- if digdata = digdata' then "resource fork"
- else if digress = digress' then "file contents"
+let reasonForFingerprintMismatch (fpdata,fpress) (fpdata',fpress') =
+ if fpdata = fpdata' then "resource fork"
+ else if fpress = fpress' then "file contents"
else "both file contents and resource fork"
let fullfingerprint_dummy = (Fingerprint.dummy,Fingerprint.dummy)
Modified: trunk/src/os.mli
===================================================================
--- trunk/src/os.mli 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/os.mli 2011-04-16 20:39:33 UTC (rev 473)
@@ -36,7 +36,6 @@
(* Use this function if the file may change during fingerprinting *)
val safeFingerprint :
- ?newfile:bool -> (* true if this file is new; false by default *)
Fspath.t -> Path.local -> (* coordinates of file to fingerprint *)
Fileinfo.t -> (* old fileinfo *)
fullfingerprint option -> (* fingerprint corresponding to the old fileinfo *)
@@ -47,12 +46,11 @@
Fileinfo.t -> (* old fileinfo *)
fullfingerprint (* current fingerprint *)
-(* BCP: Not sure this needs to be exported
val pseudoFingerprint :
+ Path.local -> (* path of file to "fingerprint" *)
Uutil.Filesize.t -> (* size of file to "fingerprint" *)
fullfingerprint (* pseudo-fingerprint of this file (containing just
- the file's length) *)
-*)
+ the file's length and path) *)
val isPseudoFingerprint :
fullfingerprint -> bool
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/uigtk2.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -3721,77 +3721,8 @@
end in
(*********************************************************************
- Quit button
+ Buttons for -->, M, <--, Skip
*********************************************************************)
-(* actionBar#insert_space ();
- ignore (actionBar#insert_button ~text:"Quit"
- ~icon:((GMisc.image ~stock:`QUIT ())#coerce)
- ~tooltip:"Exit Unison"
- ~callback:safeExit ());
-*)
-
- (*********************************************************************
- go button
- *********************************************************************)
-(* actionBar#insert_space ();*)
- grAdd grGo
- (actionBar#insert_button ~text:"Go"
- (* tooltip:"Go with displayed actions" *)
- ~icon:((GMisc.image ~stock:`EXECUTE ())#coerce)
- ~tooltip:"Perform the synchronization"
- ~callback:(fun () ->
- getLock synchronize) ());
-
- (* Does not quite work: too slow, and Files.copy must be modifed to
- support an interruption without error. *)
- (*
- ignore (actionBar#insert_button ~text:"Stop"
- ~icon:((GMisc.image ~stock:`STOP ())#coerce)
- ~tooltip:"Exit Unison"
- ~callback:Abort.all ());
- *)
-
- (*********************************************************************
- Rescan button
- *********************************************************************)
- let updateFromProfile = ref (fun () -> ()) in
-
- let loadProfile p reload =
- debug (fun()-> Util.msg "Loading profile %s..." p);
- Trace.status "Loading profile";
- Uicommon.initPrefs p
- (fun () -> if not reload then displayWaitMessage ())
- getFirstRoot getSecondRoot termInteract;
- !updateFromProfile ()
- in
-
- let reloadProfile () =
- let n =
- match !Prefs.profileName with
- None -> assert false
- | Some n -> n
- in
- clearMainWindow ();
- if not (Prefs.profileUnchanged ()) then loadProfile n true
- in
-
- let detectCmd () =
- getLock detectUpdatesAndReconcile;
- updateDetails ();
- if Prefs.read Globals.batch then begin
- Prefs.set Globals.batch false; synchronize()
- end
- in
-(* actionBar#insert_space ();*)
- grAdd grRescan
- (actionBar#insert_button ~text:"Rescan"
- ~icon:((GMisc.image ~stock:`REFRESH ())#coerce)
- ~tooltip:"Check for updates"
- ~callback: (fun () -> reloadProfile(); detectCmd()) ());
-
- (*********************************************************************
- Buttons for <--, M, -->, Skip
- *********************************************************************)
let doActionOnRow f i =
let theSI = !theState.(i) in
begin match theSI.whatHappened, theSI.ri.replicas with
@@ -3843,15 +3774,15 @@
let questionAction _ = doAction (fun _ diff -> diff.direction <- Conflict) in
let mergeAction _ = doAction (fun _ diff -> diff.direction <- Merge) in
- actionBar#insert_space ();
+(* actionBar#insert_space ();*)
grAdd grAction
(actionBar#insert_button
-(* ~icon:((GMisc.pixmap leftArrowBlack ())#coerce)*)
- ~icon:((GMisc.image ~stock:`GO_BACK ())#coerce)
- ~text:"Right to Left"
+(* ~icon:((GMisc.pixmap rightArrowBlack ())#coerce)*)
+ ~icon:((GMisc.image ~stock:`GO_FORWARD ())#coerce)
+ ~text:"Left to Right"
~tooltip:"Propagate selected items\n\
- from the right replica to the left one"
- ~callback:leftAction ());
+ from the left replica to the right one"
+ ~callback:rightAction ());
(* actionBar#insert_space ();*)
grAdd grAction
(actionBar#insert_button ~text:"Skip"
@@ -3861,12 +3792,12 @@
(* actionBar#insert_space ();*)
grAdd grAction
(actionBar#insert_button
-(* ~icon:((GMisc.pixmap rightArrowBlack ())#coerce)*)
- ~icon:((GMisc.image ~stock:`GO_FORWARD ())#coerce)
- ~text:"Left to Right"
+(* ~icon:((GMisc.pixmap leftArrowBlack ())#coerce)*)
+ ~icon:((GMisc.image ~stock:`GO_BACK ())#coerce)
+ ~text:"Right to Left"
~tooltip:"Propagate selected items\n\
- from the left replica to the right one"
- ~callback:rightAction ());
+ from the right replica to the left one"
+ ~callback:leftAction ());
(* actionBar#insert_space ();*)
grAdd grAction
(actionBar#insert_button
@@ -3922,6 +3853,75 @@
~callback:showDetCommand ());
(*********************************************************************
+ Quit button
+ *********************************************************************)
+(* actionBar#insert_space ();
+ ignore (actionBar#insert_button ~text:"Quit"
+ ~icon:((GMisc.image ~stock:`QUIT ())#coerce)
+ ~tooltip:"Exit Unison"
+ ~callback:safeExit ());
+*)
+
+ (*********************************************************************
+ go button
+ *********************************************************************)
+ actionBar#insert_space ();
+ grAdd grGo
+ (actionBar#insert_button ~text:"Go"
+ (* tooltip:"Go with displayed actions" *)
+ ~icon:((GMisc.image ~stock:`EXECUTE ())#coerce)
+ ~tooltip:"Perform the synchronization"
+ ~callback:(fun () ->
+ getLock synchronize) ());
+
+ (* Does not quite work: too slow, and Files.copy must be modifed to
+ support an interruption without error. *)
+ (*
+ ignore (actionBar#insert_button ~text:"Stop"
+ ~icon:((GMisc.image ~stock:`STOP ())#coerce)
+ ~tooltip:"Exit Unison"
+ ~callback:Abort.all ());
+ *)
+
+ (*********************************************************************
+ Rescan button
+ *********************************************************************)
+ let updateFromProfile = ref (fun () -> ()) in
+
+ let loadProfile p reload =
+ debug (fun()-> Util.msg "Loading profile %s..." p);
+ Trace.status "Loading profile";
+ Uicommon.initPrefs p
+ (fun () -> if not reload then displayWaitMessage ())
+ getFirstRoot getSecondRoot termInteract;
+ !updateFromProfile ()
+ in
+
+ let reloadProfile () =
+ let n =
+ match !Prefs.profileName with
+ None -> assert false
+ | Some n -> n
+ in
+ clearMainWindow ();
+ if not (Prefs.profileUnchanged ()) then loadProfile n true
+ in
+
+ let detectCmd () =
+ getLock detectUpdatesAndReconcile;
+ updateDetails ();
+ if Prefs.read Globals.batch then begin
+ Prefs.set Globals.batch false; synchronize()
+ end
+ in
+(* actionBar#insert_space ();*)
+ grAdd grRescan
+ (actionBar#insert_button ~text:"Rescan"
+ ~icon:((GMisc.image ~stock:`REFRESH ())#coerce)
+ ~tooltip:"Check for updates"
+ ~callback: (fun () -> reloadProfile(); detectCmd()) ());
+
+ (*********************************************************************
Profile change button
*********************************************************************)
actionBar#insert_space ();
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2011-04-16 20:35:38 UTC (rev 472)
+++ trunk/src/update.ml 2011-04-16 20:39:33 UTC (rev 473)
@@ -1269,13 +1269,13 @@
end
(* Check whether a file has changed has changed, by comparing its digest and
- properties against [archDesc], [archDig], and [archStamp].
+ properties against [archDesc], [archFp], and [archStamp].
Returns a pair (optArch, ui) where [optArch] is *not* None when the file remains
unchanged but time might be changed. [optArch] is used by [buildUpdate]
series functions to compute the _old_ archive with updated time stamp
(thus, there will no false update the next time) *)
let checkContentsChange
- currfspath path info archive archDesc archDig archStamp archRess scanInfo
+ currfspath path info archive archDesc archFp archStamp archRess scanInfo
: archive option * Common.updateItem
=
debug (fun () ->
@@ -1302,21 +1302,21 @@
Fpcache.ressClearlyUnchanged fastCheck info archRess dataClearlyUnchanged
in
if dataClearlyUnchanged && ressClearlyUnchanged then begin
- Xferhint.insertEntry currfspath path archDig;
+ Xferhint.insertEntry currfspath path archFp;
None, checkPropChange info.Fileinfo.desc archive archDesc
end else begin
debugverbose (fun() -> Util.msg " Double-check possibly updated file\n");
showStatusAddLength scanInfo info;
- let (newDesc, newDigest, newStamp, newRess) =
+ let (newDesc, newFp, newStamp, newRess) =
Fpcache.fingerprint fastCheck currfspath path info
- (if dataClearlyUnchanged then Some archDig else None) in
- Xferhint.insertEntry currfspath path newDigest;
+ (if dataClearlyUnchanged then Some archFp else None) in
+ Xferhint.insertEntry currfspath path newFp;
debug (fun() -> Util.msg " archive digest = %s current digest = %s\n"
- (Os.fullfingerprint_to_string archDig)
- (Os.fullfingerprint_to_string newDigest));
- if archDig = newDigest then begin
+ (Os.fullfingerprint_to_string archFp)
+ (Os.fullfingerprint_to_string newFp));
+ if archFp = newFp then begin
let newprops = Props.setTime archDesc (Props.time newDesc) in
- let newarch = ArchiveFile (newprops, archDig, newStamp, newRess) in
+ let newarch = ArchiveFile (newprops, archFp, newStamp, newRess) in
debugverbose (fun() ->
Util.msg " Contents match: update archive with new time...%f\n"
(Props.time newprops));
@@ -1324,7 +1324,7 @@
end else begin
debug (fun() -> Util.msg " Updated file\n");
None,
- Updates (File (newDesc, ContentsUpdated (newDigest, newStamp, newRess)),
+ Updates (File (newDesc, ContentsUpdated (newFp, newStamp, newRess)),
oldInfoOf archive)
end
end
@@ -1404,8 +1404,8 @@
NameMap.iter
(fun nm archive ->
match archive with
- ArchiveFile (_, archDig, _, _) ->
- Xferhint.insertEntry fspath (Path.child path nm) archDig
+ ArchiveFile (_, archFp, _, _) ->
+ Xferhint.insertEntry fspath (Path.child path nm) archFp
| _ ->
())
archChi;
@@ -1457,8 +1457,8 @@
`Ok | `Abs ->
if skip && archive <> NoArchive && status <> `Abs then begin
begin match archive with
- ArchiveFile (_, archDig, _, _) ->
- Xferhint.insertEntry fspath path' archDig
+ ArchiveFile (_, archFp, _, _) ->
+ Xferhint.insertEntry fspath path' archFp
| _ ->
()
end;
@@ -1542,20 +1542,20 @@
debug (fun() -> Util.msg " buildUpdate -> Deleted\n");
None, Updates (Absent, oldInfoOf archive)
(* --- *)
- | (`FILE, ArchiveFile (archDesc, archDig, archStamp, archRess)) ->
+ | (`FILE, ArchiveFile (archDesc, archFp, archStamp, archRess)) ->
checkContentsChange
currfspath path info archive
- archDesc archDig archStamp archRess scanInfo
+ archDesc archFp archStamp archRess scanInfo
| (`FILE, _) ->
debug (fun() -> Util.msg " buildUpdate -> New file\n");
None,
begin
showStatusAddLength scanInfo info;
- let (desc, dig, stamp, ress) =
+ let (desc, fp, stamp, ress) =
Fpcache.fingerprint ~newfile:true
scanInfo.fastCheck currfspath path info None in
- Xferhint.insertEntry currfspath path dig;
- Updates (File (desc, ContentsUpdated (dig, stamp, ress)),
+ Xferhint.insertEntry currfspath path fp;
+ Updates (File (desc, ContentsUpdated (fp, stamp, ress)),
oldInfoOf archive)
end
(* --- *)
@@ -1958,13 +1958,13 @@
NoArchive
| File (desc, ContentsSame) ->
begin match archive with
- ArchiveFile (_, dig, stamp, ress) ->
- ArchiveFile (desc, dig, stamp, ress)
+ ArchiveFile (_, fp, stamp, ress) ->
+ ArchiveFile (desc, fp, stamp, ress)
| _ ->
assert false
end
- | File (desc, ContentsUpdated (dig, stamp, ress)) ->
- ArchiveFile (desc, dig, stamp, ress)
+ | File (desc, ContentsUpdated (fp, stamp, ress)) ->
+ ArchiveFile (desc, fp, stamp, ress)
| Symlink l ->
ArchiveSymlink l
| Dir (desc, children, _, _) ->
@@ -2005,8 +2005,8 @@
NoArchive -> ch
| ar' -> NameMap.add nm ar' ch)
children NameMap.empty)
- | ArchiveFile (desc, dig, stamp, ress) ->
- ArchiveFile (Props.strip desc, dig, stamp, ress)
+ | ArchiveFile (desc, fp, stamp, ress) ->
+ ArchiveFile (Props.strip desc, fp, stamp, ress)
| ArchiveSymlink _ | NoArchive ->
arch
@@ -2088,13 +2088,13 @@
match ui with
Updates (File (desc, ContentsSame), _) ->
begin match arch with
- ArchiveFile (_, dig, stamp, ress) ->
- ArchiveFile (desc, dig, stamp, ress)
+ ArchiveFile (_, fp, stamp, ress) ->
+ ArchiveFile (desc, fp, stamp, ress)
| _ ->
assert false
end
- | Updates (File (desc, ContentsUpdated (dig, stamp, ress)), _) ->
- ArchiveFile(desc, dig, stamp, ress)
+ | Updates (File (desc, ContentsUpdated (fp, stamp, ress)), _) ->
+ ArchiveFile(desc, fp, stamp, ress)
| Updates (Dir (desc, _, _, _), _) ->
begin match arch with
ArchiveDir (_, children) -> ArchiveDir (desc, children)
@@ -2108,8 +2108,8 @@
match propOpt with
Some desc' ->
begin match newArch with
- ArchiveFile (desc, dig, stamp, ress) ->
- ArchiveFile (Props.override desc desc', dig, stamp, ress)
+ ArchiveFile (desc, fp, stamp, ress) ->
+ ArchiveFile (Props.override desc desc', fp, stamp, ress)
| ArchiveDir (desc, children) ->
ArchiveDir (Props.override desc desc', children)
| _ ->
@@ -2145,9 +2145,9 @@
let doMarkPossiblyUpdated arch =
match arch with
- ArchiveFile (desc, dig, stamp, ress) ->
+ ArchiveFile (desc, fp, stamp, ress) ->
(* It would be cleaner to have a special stamp for this *)
- ArchiveFile (desc, dig, Fileinfo.InodeStamp (-1), ress)
+ ArchiveFile (desc, fp, Fileinfo.InodeStamp (-1), ress)
| _ ->
(* Should not happen, actually. But this is hard to test... *)
arch
More information about the Unison-hackers
mailing list