[Unison-hackers] [unison-svn] r377 - trunk/src
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Fri Jul 17 17:41:59 EDT 2009
Author: vouillon
Date: 2009-07-17 17:41:58 -0400 (Fri, 17 Jul 2009)
New Revision: 377
Modified:
trunk/src/.depend
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/fingerprint.mli
trunk/src/mkProjectInfo.ml
trunk/src/os.ml
trunk/src/os.mli
trunk/src/stasher.ml
trunk/src/stasher.mli
trunk/src/update.ml
trunk/src/update.mli
trunk/src/xferhint.ml
trunk/src/xferhint.mli
Log:
* Performance improvement in Xferhint module.
Update this cache more accurately during transport.
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/.depend 2009-07-17 21:41:58 UTC (rev 377)
@@ -15,19 +15,19 @@
fingerprint.cmi: uutil.cmi path.cmi fspath.cmi
fs.cmi: system/system_intf.cmo fspath.cmi
fspath.cmi: system.cmi path.cmi name.cmi
-globals.cmi: ubase/prefs.cmi path.cmi lwt/lwt.cmi common.cmi
+globals.cmi: ubase/prefs.cmi pred.cmi path.cmi lwt/lwt.cmi common.cmi
lock.cmi: system.cmi
name.cmi:
os.cmi: system.cmi props.cmi path.cmi name.cmi fspath.cmi fileinfo.cmi
osx.cmi: uutil.cmi ubase/prefs.cmi path.cmi fspath.cmi fingerprint.cmi
-path.cmi: name.cmi
+path.cmi: pred.cmi name.cmi
pred.cmi:
props.cmi: uutil.cmi ubase/prefs.cmi path.cmi osx.cmi fspath.cmi
recon.cmi: path.cmi common.cmi
remote.cmi: ubase/prefs.cmi lwt/lwt.cmi fspath.cmi common.cmi clroot.cmi \
bytearray.cmi
sortri.cmi: common.cmi
-stasher.cmi: ubase/prefs.cmi path.cmi os.cmi fspath.cmi
+stasher.cmi: update.cmi ubase/prefs.cmi path.cmi os.cmi fspath.cmi
strings.cmi:
system.cmi: system/system_intf.cmo
terminal.cmi:
@@ -44,7 +44,8 @@
update.cmi: uutil.cmi tree.cmi props.cmi path.cmi osx.cmi os.cmi name.cmi \
lwt/lwt.cmi fspath.cmi fileinfo.cmi common.cmi
uutil.cmi:
-xferhint.cmi: ubase/prefs.cmi path.cmi os.cmi fspath.cmi
+xferhint.cmi: props.cmi ubase/prefs.cmi path.cmi osx.cmi os.cmi fspath.cmi \
+ fileinfo.cmi
abort.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi abort.cmi
abort.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx ubase/prefs.cmx abort.cmi
bytearray.cmo: bytearray.cmi
@@ -59,16 +60,16 @@
osx.cmi os.cmi name.cmi fspath.cmi fileinfo.cmi common.cmi
common.cmx: uutil.cmx ubase/util.cmx ubase/safelist.cmx props.cmx path.cmx \
osx.cmx os.cmx name.cmx fspath.cmx fileinfo.cmx common.cmi
-copy.cmo: xferhint.cmi uutil.cmi ubase/util.cmi transfer.cmi ubase/trace.cmi \
- ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi \
- os.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi fspath.cmi fs.cmi \
- fileinfo.cmi external.cmi common.cmi clroot.cmi bytearray.cmi abort.cmi \
- copy.cmi
-copy.cmx: xferhint.cmx uutil.cmx ubase/util.cmx transfer.cmx ubase/trace.cmx \
- ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx \
- os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx \
- fileinfo.cmx external.cmx common.cmx clroot.cmx bytearray.cmx abort.cmx \
- copy.cmi
+copy.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi transfer.cmi \
+ ubase/trace.cmi ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi \
+ path.cmi osx.cmi os.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi \
+ fspath.cmi fs.cmi fileinfo.cmi external.cmi common.cmi clroot.cmi \
+ bytearray.cmi abort.cmi copy.cmi
+copy.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx transfer.cmx \
+ ubase/trace.cmx ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx \
+ path.cmx osx.cmx os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx \
+ fspath.cmx fs.cmx fileinfo.cmx external.cmx common.cmx clroot.cmx \
+ bytearray.cmx abort.cmx copy.cmi
external.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi lwt/lwt_util.cmi \
lwt/lwt_unix.cmi lwt/lwt.cmi external.cmi
external.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx lwt/lwt_util.cmx \
@@ -77,18 +78,18 @@
osx.cmi fspath.cmi fs.cmi fileinfo.cmi
fileinfo.cmx: ubase/util.cmx system.cmx props.cmx ubase/prefs.cmx path.cmx \
osx.cmx fspath.cmx fs.cmx fileinfo.cmi
-files.cmo: uutil.cmi ubase/util.cmi update.cmi ubase/trace.cmi system.cmi \
- stasher.cmi ubase/safelist.cmi ubase/rx.cmi remote.cmi props.cmi \
- ubase/prefs.cmi path.cmi osx.cmi os.cmi name.cmi lwt/lwt_util.cmi \
- lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi fs.cmi \
- fingerprint.cmi fileinfo.cmi external.cmi copy.cmi common.cmi abort.cmi \
- files.cmi
-files.cmx: uutil.cmx ubase/util.cmx update.cmx ubase/trace.cmx system.cmx \
- stasher.cmx ubase/safelist.cmx ubase/rx.cmx remote.cmx props.cmx \
- ubase/prefs.cmx path.cmx osx.cmx os.cmx name.cmx lwt/lwt_util.cmx \
- lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx \
- fingerprint.cmx fileinfo.cmx external.cmx copy.cmx common.cmx abort.cmx \
- files.cmi
+files.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi ubase/trace.cmi \
+ system.cmi stasher.cmi ubase/safelist.cmi ubase/rx.cmi remote.cmi \
+ props.cmi ubase/prefs.cmi path.cmi osx.cmi os.cmi name.cmi \
+ lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi \
+ fs.cmi fingerprint.cmi fileinfo.cmi external.cmi copy.cmi common.cmi \
+ abort.cmi files.cmi
+files.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx ubase/trace.cmx \
+ system.cmx stasher.cmx ubase/safelist.cmx ubase/rx.cmx remote.cmx \
+ props.cmx ubase/prefs.cmx path.cmx osx.cmx os.cmx name.cmx \
+ lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx \
+ fs.cmx fingerprint.cmx fileinfo.cmx external.cmx copy.cmx common.cmx \
+ abort.cmx files.cmi
fileutil.cmo: fileutil.cmi
fileutil.cmx: fileutil.cmi
fingerprint.cmo: uutil.cmi ubase/util.cmi fspath.cmi fs.cmi fingerprint.cmi
@@ -165,14 +166,14 @@
path.cmi common.cmi sortri.cmi
sortri.cmx: ubase/util.cmx ubase/safelist.cmx ubase/prefs.cmx pred.cmx \
path.cmx common.cmx sortri.cmi
-stasher.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi remote.cmi \
- props.cmi ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi \
- lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi fingerprint.cmi \
- fileutil.cmi fileinfo.cmi copy.cmi common.cmi stasher.cmi
-stasher.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx remote.cmx \
- props.cmx ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx \
- lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx fingerprint.cmx \
- fileutil.cmx fileinfo.cmx copy.cmx common.cmx stasher.cmi
+stasher.cmo: xferhint.cmi ubase/util.cmi update.cmi system.cmi \
+ ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi pred.cmi path.cmi \
+ osx.cmi os.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi \
+ fingerprint.cmi fileutil.cmi fileinfo.cmi copy.cmi common.cmi stasher.cmi
+stasher.cmx: xferhint.cmx ubase/util.cmx update.cmx system.cmx \
+ ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx pred.cmx path.cmx \
+ osx.cmx os.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx \
+ fingerprint.cmx fileutil.cmx fileinfo.cmx copy.cmx common.cmx stasher.cmi
strings.cmo: strings.cmi
strings.cmx: strings.cmi
system.cmo: system.cmi
@@ -268,17 +269,15 @@
unicode_tables.cmo:
unicode_tables.cmx:
update.cmo: xferhint.cmi uutil.cmi ubase/util.cmi tree.cmi ubase/trace.cmi \
- system.cmi stasher.cmi ubase/safelist.cmi remote.cmi props.cmi \
- ubase/proplist.cmi ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi \
- name.cmi ubase/myMap.cmi lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi \
- globals.cmi fspath.cmi fs.cmi fingerprint.cmi fileinfo.cmi copy.cmi \
- common.cmi case.cmi update.cmi
+ system.cmi ubase/safelist.cmi remote.cmi props.cmi ubase/proplist.cmi \
+ ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi name.cmi ubase/myMap.cmi \
+ lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi globals.cmi fspath.cmi fs.cmi \
+ fingerprint.cmi fileinfo.cmi common.cmi case.cmi update.cmi
update.cmx: xferhint.cmx uutil.cmx ubase/util.cmx tree.cmx ubase/trace.cmx \
- system.cmx stasher.cmx ubase/safelist.cmx remote.cmx props.cmx \
- ubase/proplist.cmx ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx \
- name.cmx ubase/myMap.cmx lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx \
- globals.cmx fspath.cmx fs.cmx fingerprint.cmx fileinfo.cmx copy.cmx \
- common.cmx case.cmx update.cmi
+ system.cmx ubase/safelist.cmx remote.cmx props.cmx ubase/proplist.cmx \
+ ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx name.cmx ubase/myMap.cmx \
+ lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx globals.cmx fspath.cmx fs.cmx \
+ fingerprint.cmx fileinfo.cmx common.cmx case.cmx update.cmi
uutil.cmo: ubase/util.cmi ubase/trace.cmi ubase/projectInfo.cmo uutil.cmi
uutil.cmx: ubase/util.cmx ubase/trace.cmx ubase/projectInfo.cmx uutil.cmi
xferhint.cmo: ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi path.cmi os.cmi \
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/Makefile.OCaml 2009-07-17 21:41:58 UTC (rev 377)
@@ -207,8 +207,8 @@
abort.cmo osx.cmo external.cmo \
props.cmo fileinfo.cmo os.cmo lock.cmo clroot.cmo common.cmo \
tree.cmo checksum.cmo terminal.cmo \
- transfer.cmo xferhint.cmo remote.cmo globals.cmo copy.cmo \
- stasher.cmo update.cmo \
+ transfer.cmo xferhint.cmo remote.cmo globals.cmo \
+ update.cmo copy.cmo stasher.cmo \
files.cmo sortri.cmo recon.cmo transport.cmo \
strings.cmo uicommon.cmo uitext.cmo test.cmo
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/RECENTNEWS 2009-07-17 21:41:58 UTC (rev 377)
@@ -1,5 +1,11 @@
CHANGES FROM VERSION 2.36.-27
+* Performance improvement in Xferhint module.
+ Update this cache more accurately during transport.
+
+-------------------------------
+CHANGES FROM VERSION 2.36.-27
+
* Correction to previous fix: do not perform the optimization for
directories with ignored children *in the archive*. (The previous
fix was also rejecting directories with ignored children on disk,
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/copy.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -42,11 +42,6 @@
(****)
-(* From update.ml *)
-(* (there is a dependency loop between copy.ml and update.ml...) *)
-let excelFile = ref (fun _ -> false)
-let markPossiblyUpdated = ref (fun _ _ -> ())
-
(* Check whether the source file has been modified during synchronization *)
let checkContentsChangeLocal
fspathFrom pathFrom archDesc archDig archStamp archRess paranoid =
@@ -60,7 +55,7 @@
let dataClearlyUnchanged =
not clearlyModified
&& Props.same_time info.Fileinfo.desc archDesc
- && not (!excelFile pathFrom)
+ && not (Update.excelFile pathFrom)
&& match archStamp with
Some (Fileinfo.InodeStamp inode) -> info.Fileinfo.inode = inode
| Some (Fileinfo.CtimeStamp ctime) -> true
@@ -75,7 +70,7 @@
if paranoid then begin
let newDig = Os.fingerprint fspathFrom pathFrom info in
if archDig <> newDig then begin
- !markPossiblyUpdated fspathFrom pathFrom;
+ Update.markPossiblyUpdated fspathFrom pathFrom;
raise (Util.Transient (Printf.sprintf
"The source file %s\n\
has been modified but the fast update detection mechanism\n\
@@ -248,14 +243,22 @@
match Xferhint.lookup fp with
None ->
None
- | Some (candidateFspath, candidatePath) ->
+ | Some (candidateFspath, candidatePath, hintHandle) ->
debug (fun () ->
Util.msg
"tryCopyMovedFile: found match at %s,%s. Try local copying\n"
(Fspath.toDebugString candidateFspath)
(Path.toString candidatePath));
try
- if Os.exists candidateFspath candidatePath then begin
+ (* If candidateFspath is the replica root, the argument
+ [true] is correct. Otherwise, we don't expect to point
+ to a symlink, and therefore we still get the correct
+ result. *)
+ let info = Fileinfo.get true candidateFspath candidatePath in
+ if
+ info.Fileinfo.typ <> `ABSENT &&
+ Props.length info.Fileinfo.desc = Props.length desc
+ then begin
localFile
candidateFspath candidatePath fspathTo pathTo realPathTo
update desc (Osx.ressLength ress) (Some id);
@@ -263,7 +266,6 @@
fileIsTransferred fspathTo pathTo desc fp ress in
if isTransferred then begin
debug (fun () -> Util.msg "tryCopyMoveFile: success.\n");
- Xferhint.insertEntry (fspathTo, pathTo) fp;
let msg =
Printf.sprintf
"Shortcut: copied %s/%s from local file %s/%s\n"
@@ -277,15 +279,14 @@
debug (fun () ->
Util.msg "tryCopyMoveFile: candidate file %s modified!\n"
(Path.toString candidatePath));
- Xferhint.deleteEntry (candidateFspath, candidatePath);
- Os.delete fspathTo pathTo;
+ Xferhint.deleteEntry hintHandle;
None
end
end else begin
debug (fun () ->
Util.msg "tryCopyMoveFile: candidate file %s disappeared!\n"
(Path.toString candidatePath));
- Xferhint.deleteEntry (candidateFspath, candidatePath);
+ Xferhint.deleteEntry hintHandle;
None
end
with
@@ -294,8 +295,7 @@
Util.msg
"tryCopyMovedFile: local copy from %s didn't work [%s]"
(Path.toString candidatePath) s);
- Xferhint.deleteEntry (candidateFspath, candidatePath);
- Os.delete fspathTo pathTo;
+ Xferhint.deleteEntry hintHandle;
None)
(****)
@@ -627,8 +627,11 @@
(Path.toString pathTo)));
transferRessourceForkAndSetFileinfo
connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
- update desc fp ress id
+ update desc fp ress id >>= fun res ->
+ Xferhint.insertEntry fspathTo pathTo fp;
+ Lwt.return res
+
let finishExternalTransferOnRoot =
Remote.registerRootCmdWithConnection
"finishExternalTransfer" finishExternalTransferLocal
@@ -689,6 +692,7 @@
let len = Uutil.Filesize.add (Props.length desc) (Osx.ressLength ress) in
Uutil.showProgress id len "alr";
setFileinfo fspathTo pathTo realPathTo update desc;
+ Xferhint.insertEntry fspathTo pathTo fp;
Lwt.return (`DONE (Success info, Some msg))
end else
match
@@ -696,6 +700,7 @@
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
@@ -704,6 +709,7 @@
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
Modified: trunk/src/copy.mli
===================================================================
--- trunk/src/copy.mli 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/copy.mli 2009-07-17 21:41:58 UTC (rev 377)
@@ -27,8 +27,3 @@
-> Uutil.Filesize.t (* fork length *)
-> Uutil.File.t option (* file's index in UI (for progress bars), as appropriate *)
-> unit
-
-(* From update.ml *)
-(* (there is a dependency loop between copy.ml and update.ml...) *)
-val excelFile : (Path.local -> bool) ref
-val markPossiblyUpdated : (Fspath.t -> Path.local -> unit) ref
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/files.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -79,8 +79,8 @@
let localPathTo = Update.translatePathLocal fspathTo pathTo in
(* Make sure the target is unchanged first *)
(* (There is an unavoidable race condition here.) *)
- Update.checkNoUpdates fspathTo localPathTo ui;
- Stasher.backup fspathTo localPathTo `AndRemove;
+ let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in
+ Stasher.backup fspathTo localPathTo `AndRemove prevArch;
(* Archive update must be done last *)
Update.replaceArchiveLocal fspathTo localPathTo Update.NoArchive;
Lwt.return ()
@@ -177,7 +177,7 @@
(* ------------------------------------------------------------ *)
-let performRename fspathTo localPathTo workingDir pathFrom pathTo =
+let performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch =
debug (fun () -> Util.msg "Renaming %s to %s in %s; root is %s\n"
(Path.toString pathFrom)
(Path.toString pathTo)
@@ -221,7 +221,7 @@
debug (fun() ->
Util.msg "moving %s to %s\n" (Fspath.toDebugString target) temp');
- Stasher.backup fspathTo localPathTo `ByCopying;
+ Stasher.backup fspathTo localPathTo `ByCopying prevArch;
writeCommitLog source target temp';
Util.finalize (fun() ->
(* If the first rename fails, the log can be removed: the
@@ -245,7 +245,7 @@
Os.delete temp Path.empty
end else begin
debug (fun() -> Util.msg "rename: moveFirst=false\n");
- Stasher.backup fspathTo localPathTo `ByCopying;
+ Stasher.backup fspathTo localPathTo `ByCopying prevArch;
Os.rename "renameLocal(3)" source Path.empty target Path.empty;
debug (fun() ->
if filetypeFrom = `FILE then
@@ -271,11 +271,13 @@
(fspathTo, (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt)) =
(* Make sure the target is unchanged, then do the rename.
(Note that there is an unavoidable race condition here...) *)
- Update.checkNoUpdates fspathTo localPathTo ui;
- performRename fspathTo localPathTo workingDir pathFrom pathTo;
- (* Archive update must be done last *)
+ let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in
+ performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch;
begin match archOpt with
Some archTo -> Stasher.stashCurrentVersion fspathTo localPathTo None;
+ Update.iterFiles fspathTo localPathTo archTo
+ Xferhint.insertEntry;
+ (* Archive update must be done last *)
Update.replaceArchiveLocal fspathTo localPathTo archTo
| None -> ()
end;
@@ -283,7 +285,7 @@
let renameOnHost = Remote.registerRootCmd "rename" renameLocal
-let rename root pathInArchive localPath workingDir pathOld pathNew ui archOpt =
+let rename root localPath workingDir pathOld pathNew ui archOpt =
debug (fun() ->
Util.msg "rename(root=%s, pathOld=%s, pathNew=%s)\n"
(root2string root)
@@ -518,7 +520,7 @@
else begin
(* Rename the files to their final location and then update the
archive on the destination replica *)
- rename rootTo pathTo localPathTo workingDir tempPathTo realPathTo uiTo
+ rename rootTo localPathTo workingDir tempPathTo realPathTo uiTo
(Some archTo) >>= fun () ->
(* Update the archive on the source replica
FIX: we could reuse localArch if rootFrom is the same as rootLocal *)
@@ -701,7 +703,7 @@
Copy.file
(Local, fspathFrom) pathFrom rootTo workingDirForCopy tempPathTo realPathTo
`Copy newprops fp None stamp id >>= fun info ->
- rename rootTo pathTo localPathTo workingDirForCopy tempPathTo realPathTo
+ rename rootTo localPathTo workingDirForCopy tempPathTo realPathTo
uiTo None)
let keeptempfilesaftermerge =
Modified: trunk/src/fingerprint.ml
===================================================================
--- trunk/src/fingerprint.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/fingerprint.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -79,3 +79,14 @@
let string = Digest.string
let dummy = ""
+
+let hash d =
+ if d == dummy then
+ 1234577
+ else begin
+ Char.code (String.unsafe_get d 0) +
+ (Char.code (String.unsafe_get d 1) lsl 8) +
+ (Char.code (String.unsafe_get d 2) lsl 16)
+ end
+
+let equal (d : string) d' = d = d'
Modified: trunk/src/fingerprint.mli
===================================================================
--- trunk/src/fingerprint.mli 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/fingerprint.mli 2009-07-17 21:41:58 UTC (rev 377)
@@ -14,3 +14,6 @@
(* This dummy fingerprint is guaranteed small and distinct from all
other fingerprints *)
val dummy : t
+
+val hash : t -> int
+val equal : t -> t -> bool
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/mkProjectInfo.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -95,3 +95,4 @@
+
Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/os.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -36,13 +36,6 @@
if s = "" then tempFileSuffixFixed
else "." ^ s ^ tempFileSuffixFixed
-let xferDelete = ref (fun (fp,p) -> ())
-let xferRename = ref (fun (fp,p) (ftp,tp) -> ())
-
-let initializeXferFunctions del ren =
- xferDelete := del;
- xferRename := ren
-
(*****************************************************************************)
(* QUERYING THE FILESYSTEM *)
(*****************************************************************************)
@@ -158,7 +151,6 @@
Safelist.iter
(fun child -> delete fspath (Path.child path child))
(allChildrenOf fspath path);
- (!xferDelete) (fspath, path);
Fs.rmdir absolutePath
| `FILE ->
if Util.osType <> `Unix then begin
@@ -166,7 +158,6 @@
Fs.chmod absolutePath 0o600;
with Unix.Unix_error _ -> ()
end;
- (!xferDelete) (fspath, path);
Fs.unlink absolutePath;
if Prefs.read Osx.rsrc then begin
let pathDouble = Fspath.appleDouble absolutePath in
@@ -189,7 +180,6 @@
Util.convertUnixErrorsToTransient ("renaming " ^ source' ^ " to " ^ target')
(fun () ->
debug (fun() -> Util.msg "rename %s to %s\n" source' target');
- (!xferRename) (sourcefspath, sourcepath) (targetfspath, targetpath);
Fs.rename source target;
if Prefs.read Osx.rsrc then begin
let sourceDouble = Fspath.appleDouble source in
@@ -278,6 +268,12 @@
let fullfingerprint_dummy = (Fingerprint.dummy,Fingerprint.dummy)
+let fullfingerprintHash (fp, rfp) =
+ Fingerprint.hash fp + 31 * Fingerprint.hash rfp
+
+let fullfingerprintEqual (fp, rfp) (fp', rfp') =
+ Fingerprint.equal fp fp' && Fingerprint.equal rfp rfp'
+
(*****************************************************************************)
(* UNISON DIRECTORY *)
(*****************************************************************************)
Modified: trunk/src/os.mli
===================================================================
--- trunk/src/os.mli 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/os.mli 2009-07-17 21:41:58 UTC (rev 377)
@@ -31,6 +31,8 @@
val fullfingerprint_to_string : fullfingerprint -> string
val reasonForFingerprintMismatch : fullfingerprint -> fullfingerprint -> string
val fullfingerprint_dummy : fullfingerprint
+val fullfingerprintHash : fullfingerprint -> int
+val fullfingerprintEqual : fullfingerprint -> fullfingerprint -> bool
(* Use this function if the file may change during fingerprinting *)
val safeFingerprint :
@@ -47,10 +49,3 @@
(* Versions of system calls that will restart when interrupted by
signal handling *)
val accept : Unix.file_descr -> (Unix.file_descr * Unix.sockaddr)
-
-(* Called during program initialization to resolve a circular dependency
- between this module and Xferhints *)
-val initializeXferFunctions :
- (Fspath.t * Path.local -> unit) ->
- ((Fspath.t * Path.local) -> (Fspath.t * Path.local) -> unit) ->
- unit
Modified: trunk/src/stasher.ml
===================================================================
--- trunk/src/stasher.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/stasher.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -360,7 +360,7 @@
(*------------------------------------------------------------------------------------*)
-let backup fspath path (finalDisposition : [`AndRemove | `ByCopying]) =
+let backup fspath path (finalDisposition : [`AndRemove | `ByCopying]) arch =
debug (fun () -> Util.msg
"backup: %s / %s\n"
(Fspath.toDebugString fspath)
@@ -409,14 +409,17 @@
debug (fun () -> Util.msg " Finished copying; deleting %s / %s\n"
(Fspath.toDebugString fspath) (Path.toString path));
disposeIfNeeded() in
- if finalDisposition = `AndRemove then
+ begin if finalDisposition = `AndRemove then
try
+ (*FIX: this does the wrong thing with followed symbolic links!*)
Os.rename "backup" workingDir realPath backRoot backPath
with Util.Transient _ ->
debug (fun () -> Util.msg "Rename failed -- copying instead\n");
byCopying()
else
byCopying()
+ end;
+ Update.iterFiles backRoot backPath arch Xferhint.insertEntry
end else begin
debug (fun () -> Util.msg "Path %s / %s does not need to be backed up\n"
(Fspath.toDebugString fspath)
@@ -462,7 +465,10 @@
(Osx.ressLength stat.Fileinfo.osX.Osx.ressInfo)
None
end)
-
+
+let _ =
+Update.setStasherFun (fun fspath path -> stashCurrentVersion fspath path None)
+
(*------------------------------------------------------------------------------------*)
(* This function tries to find a backup of a recent version of the file at location
Modified: trunk/src/stasher.mli
===================================================================
--- trunk/src/stasher.mli 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/stasher.mli 2009-07-17 21:41:58 UTC (rev 377)
@@ -5,9 +5,12 @@
(* This module maintains backups for general purpose and *)
(* as archives for mergeable files. *)
-(* Make a backup copy of a file, if needed; if the third parameter is `AndRemove,
- then the file is either backed up by renaming or deleted if no backup is needed. *)
-val backup: Fspath.t -> Path.local -> [`AndRemove | `ByCopying] -> unit
+(* Make a backup copy of a file, if needed; if the third parameter is
+ `AndRemove, then the file is either backed up by renaming or
+ deleted if no backup is needed. *)
+val backup:
+ Fspath.t -> Path.local ->
+ [`AndRemove | `ByCopying] -> Update.archive -> unit
(* Stashes of current versions (so that we have archives when needed for merging) *)
val stashCurrentVersion:
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/update.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -1223,7 +1223,7 @@
Osx.ressUnchanged archRess info.Fileinfo.osX.Osx.ressInfo
None dataClearlyUnchanged in
if dataClearlyUnchanged && ressClearlyUnchanged then begin
- Xferhint.insertEntry (currfspath, path) archDig;
+ Xferhint.insertEntry currfspath path archDig;
None, checkPropChange info archive archDesc
end else begin
debugverbose (fun() -> Util.msg " Double-check possibly updated file\n");
@@ -1231,7 +1231,7 @@
let (info, newDigest) =
Os.safeFingerprint currfspath path info
(if dataClearlyUnchanged then Some archDig else None) in
- Xferhint.insertEntry (currfspath, path) newDigest;
+ Xferhint.insertEntry currfspath path newDigest;
debug (fun() -> Util.msg " archive digest = %s current digest = %s\n"
(Os.fullfingerprint_to_string archDig)
(Os.fullfingerprint_to_string newDigest));
@@ -1239,7 +1239,6 @@
let newprops = Props.setTime archDesc (Props.time info.Fileinfo.desc) in
let newarch =
ArchiveFile
-
(newprops, archDig, Fileinfo.stamp info, Fileinfo.ressStamp info) in
debugverbose (fun() ->
Util.msg " Contents match: update archive with new time...%f\n"
@@ -1330,8 +1329,8 @@
NameMap.iter
(fun nm archive ->
match archive with
- ArchiveFile (archDesc, archDig, archStamp, archRess) ->
- Xferhint.insertEntry (fspath, Path.child path nm) archDig
+ ArchiveFile (_, archDig, _, _) ->
+ Xferhint.insertEntry fspath (Path.child path nm) archDig
| _ ->
())
archChi;
@@ -1374,8 +1373,8 @@
`Ok | `Abs ->
if skip && archive <> NoArchive && status <> `Abs then begin
begin match archive with
- ArchiveFile (archDesc, archDig, archStamp, archRess) ->
- Xferhint.insertEntry (fspath, path') archDig
+ ArchiveFile (_, archDig, _, _) ->
+ Xferhint.insertEntry fspath path' archDig
| _ ->
()
end;
@@ -1469,7 +1468,7 @@
begin
showStatusAddLength info;
let (info, dig) = Os.safeFingerprint currfspath path info None in
- Xferhint.insertEntry (currfspath, path) dig;
+ Xferhint.insertEntry currfspath path dig;
Updates (File (info.Fileinfo.desc,
ContentsUpdated (dig, Fileinfo.stamp info,
Fileinfo.ressStamp info)),
@@ -1909,6 +1908,10 @@
let (_, subArch) = getPathInArchive archive Path.empty path in
updateArchiveRec ui (stripArchive path subArch)
+(* (For breaking the dependency loop between update.ml and stasher.ml...) *)
+let stashCurrentVersion = ref (fun _ _ -> ())
+let setStasherFun f = stashCurrentVersion := f
+
(* This function is called for files changed only in identical ways.
It only updates the archives and perhaps makes backups. *)
let markEqualLocal fspath paths =
@@ -1922,7 +1925,7 @@
let arch =
updatePathInArchive !archive fspath Path.empty path
(fun archive localPath ->
- Stasher.stashCurrentVersion fspath localPath None;
+ !stashCurrentVersion fspath localPath;
updateArchiveRec (Updates (uc, New)) archive)
in
archive := arch);
@@ -2136,7 +2139,8 @@
in
let (_, uiNew) = buildUpdateRec archive fspath localPath fastCheckInfos in
markPossiblyUpdatedRec fspath pathInArchive uiNew;
- explainUpdate pathInArchive uiNew
+ explainUpdate pathInArchive uiNew;
+ archive
(*****************************************************************************)
(* UPDATE SIZE *)
@@ -2213,9 +2217,16 @@
let (_, subArch) = getPathInArchive archive Path.empty path in
updateSizeRec subArch ui
-(*****)
+(*****************************************************************************)
+(* MISC *)
+(*****************************************************************************)
-(* There is a dependency loop between copy.ml and update.ml... *)
-let _ =
-Copy.excelFile := excelFile;
-Copy.markPossiblyUpdated := markPossiblyUpdated
+let rec iterFiles fspath path arch f =
+ match arch with
+ ArchiveDir (_, children) ->
+ NameMap.iter
+ (fun nm arch -> iterFiles fspath (Path.child path nm) arch f) children
+ | ArchiveFile (desc, fp, stamp, ress) ->
+ f fspath path fp
+ | _ ->
+ ()
Modified: trunk/src/update.mli
===================================================================
--- trunk/src/update.mli 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/update.mli 2009-07-17 21:41:58 UTC (rev 377)
@@ -36,7 +36,9 @@
Fspath.t -> 'a Path.path -> Props.t option -> Common.updateItem -> unit
(* Check that no updates has taken place in a given place of the filesystem *)
-val checkNoUpdates : Fspath.t -> Path.local -> Common.updateItem -> unit
+(* Returns an archive mirroring the filesystem contents *)
+val checkNoUpdates :
+ Fspath.t -> Path.local -> Common.updateItem -> archive
(* Turn off fastcheck for the given file on the next sync. *)
val markPossiblyUpdated : Fspath.t -> Path.local -> unit
@@ -61,8 +63,19 @@
(* Are we checking fast, or carefully? *)
val useFastChecking : unit -> bool
+(* Is that a file for which fast checking is disabled? *)
+val excelFile : Path.local -> bool
+
(* Print the archive to the current formatter (see Format) *)
val showArchive: archive -> unit
(* Compute the size of an update *)
val updateSize : Path.t -> Common.updateItem -> int * Uutil.Filesize.t
+
+(* Iterate on all files in an archive *)
+val iterFiles :
+ Fspath.t -> Path.local -> archive ->
+ (Fspath.t -> Path.local -> Os.fullfingerprint -> unit) -> unit
+
+(* (For breaking the dependency loop between update.ml and stasher.ml...) *)
+val setStasherFun : (Fspath.t -> Path.local -> unit) -> unit
Modified: trunk/src/xferhint.ml
===================================================================
--- trunk/src/xferhint.ml 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/xferhint.ml 2009-07-17 21:41:58 UTC (rev 377)
@@ -27,89 +27,39 @@
^ "allows file moves to be propagated very quickly. The default value is"
^ "\\texttt{true}. ")
-module PathMap =
- Hashtbl.Make
- (struct
- type t = Fspath.t * Path.local
- let hash (fspath, path) =
- (Fspath.hash fspath + 13217 * Path.hash path)
- land
- 0x3FFFFFFF
- let equal = (=)
- end)
module FPMap =
Hashtbl.Make
(struct
type t = Os.fullfingerprint
- let hash = Hashtbl.hash
- let equal = (=)
+ let hash = Os.fullfingerprintHash
+ let equal = Os.fullfingerprintEqual
end)
-(* map(path, fingerprint) *)
-let path2fingerprintMap = PathMap.create 101
+type handle = Os.fullfingerprint
+
(* map(fingerprint, path) *)
-let fingerprint2pathMap = FPMap.create 101
+let fingerprint2pathMap = FPMap.create 10000
-(* Now we don't clear it out anymore
-let initLocal () =
- debug (fun () -> Util.msg "initLocal\n");
- path2fingerprintMap := PathMap.empty;
- fingerprint2pathMap := FPMap.empty
-*)
+let deleteEntry fp =
+ debug (fun () ->
+ Util.msg "deleteEntry: fp=%s\n" (Os.fullfingerprint_to_string fp));
+ FPMap.remove fingerprint2pathMap fp
let lookup fp =
assert (Prefs.read xferbycopying);
debug (fun () ->
Util.msg "lookup: fp = %s\n" (Os.fullfingerprint_to_string fp));
try
- Some (FPMap.find fingerprint2pathMap fp)
+ let (fspath, path) = FPMap.find fingerprint2pathMap fp in
+ Some (fspath, path, fp)
with Not_found ->
None
-let insertEntry p fp =
+let insertEntry fspath path fp =
if Prefs.read xferbycopying then begin
debug (fun () ->
- let (fspath, path) = p in
Util.msg "insertEntry: fspath=%s, path=%s, fp=%s\n"
(Fspath.toDebugString fspath)
(Path.toString path) (Os.fullfingerprint_to_string fp));
- (* Neither of these should be able to raise Not_found *)
- PathMap.replace path2fingerprintMap p fp;
- FPMap.replace fingerprint2pathMap fp p
+ FPMap.replace fingerprint2pathMap fp (fspath, path)
end
-
-let deleteEntry p =
- if Prefs.read xferbycopying then begin
- debug (fun () ->
- let (fspath, path) = p in
- Util.msg "deleteEntry: fspath=%s, path=%s\n"
- (Fspath.toDebugString fspath) (Path.toString path));
- try
- let fp = PathMap.find path2fingerprintMap p in
- PathMap.remove path2fingerprintMap p;
- let p' = FPMap.find fingerprint2pathMap fp in
- (* Maybe we should do this unconditionally *)
- if p' = p then FPMap.remove fingerprint2pathMap fp
- with Not_found ->
- ()
- end
-
-let renameEntry pOrig pNew =
- if Prefs.read xferbycopying then begin
- debug (fun () ->
- let (fspathOrig, pathOrig) = pOrig in
- let (fspathNew, pathNew) = pNew in
- Util.msg "renameEntry: fsOrig=%s, pOrig=%s, fsNew=%s, pNew=%s\n"
- (Fspath.toDebugString fspathOrig) (Path.toString pathOrig)
- (Fspath.toDebugString fspathNew) (Path.toString pathNew));
- try
- let fp = PathMap.find path2fingerprintMap pOrig in
- PathMap.remove path2fingerprintMap pOrig;
- PathMap.replace path2fingerprintMap pNew fp;
- FPMap.replace fingerprint2pathMap fp pNew
- with Not_found ->
- ()
- end
-
-let _ =
- Os.initializeXferFunctions deleteEntry renameEntry
Modified: trunk/src/xferhint.mli
===================================================================
--- trunk/src/xferhint.mli 2009-07-17 08:15:02 UTC (rev 376)
+++ trunk/src/xferhint.mli 2009-07-17 21:41:58 UTC (rev 377)
@@ -9,10 +9,13 @@
val xferbycopying: bool Prefs.t
+type handle
+
(* Suggest a file that's likely to have a given fingerprint *)
-val lookup: Os.fullfingerprint -> (Fspath.t * Path.local) option
+val lookup: Os.fullfingerprint -> (Fspath.t * Path.local * handle) option
-(* Add, delete, and rename entries *)
-val insertEntry: Fspath.t * Path.local -> Os.fullfingerprint -> unit
-val deleteEntry: Fspath.t * Path.local -> unit
-val renameEntry: Fspath.t * Path.local -> Fspath.t * Path.local -> unit
+(* Add a file *)
+val insertEntry: Fspath.t -> Path.local -> Os.fullfingerprint -> unit
+
+(* Delete an entry *)
+val deleteEntry: handle -> unit
More information about the Unison-hackers
mailing list