[Unison-hackers] [unison-svn] r505 - trunk/src
vouillon at seas.upenn.edu
vouillon at seas.upenn.edu
Thu Aug 9 10:22:34 EDT 2012
Author: vouillon
Date: 2012-08-09 10:22:34 -0400 (Thu, 09 Aug 2012)
New Revision: 505
Modified:
trunk/src/RECENTNEWS
trunk/src/copy.ml
trunk/src/copy.mli
trunk/src/files.ml
trunk/src/files.mli
trunk/src/mkProjectInfo.ml
trunk/src/path.ml
trunk/src/path.mli
trunk/src/stasher.ml
trunk/src/transport.ml
Log:
* Added a "copyonconflict" preference, to make a copy of files that would
otherwise be overwritten or deleted in case of conflicting changes.
(This makes it possible to automatically resolve conflicts in a
fairly safe way when synchronizing continuously, in combination
with the "repeat = watch" and "prefer = newer" preferences.
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/RECENTNEWS 2012-08-09 14:22:34 UTC (rev 505)
@@ -1,3 +1,12 @@
+CHANGES FROM VERSION 2.46.0
+
+* Added a "copyonconflict" preference, to make a copy of files that would
+ otherwise be overwritten or deleted in case of conflicting changes.
+ (This makes it possible to automatically resolve conflicts in a
+ fairly safe way when synchronizing continuously, in combination
+ with the "repeat = watch" and "prefer = newer" preferences.
+
+-------------------------------
CHANGES FROM VERSION 2.46.-1
* Bumped version number: incompatible protocol changes
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/copy.ml 2012-08-09 14:22:34 UTC (rev 505)
@@ -977,3 +977,36 @@
>>= fun () ->
(* This function never returns (it is supposed to fail) *)
saveTempFileOnRoot rootTo (pathTo, realPathTo, reason)
+
+(****)
+
+let recursively fspathFrom pathFrom fspathTo pathTo =
+ let rec copy pFrom pTo =
+ let info = Fileinfo.get true fspathFrom pFrom in
+ match info.Fileinfo.typ with
+ | `SYMLINK ->
+ debug (fun () -> Util.msg " Copying link %s / %s to %s / %s\n"
+ (Fspath.toDebugString fspathFrom) (Path.toString pFrom)
+ (Fspath.toDebugString fspathTo) (Path.toString pTo));
+ Os.symlink fspathTo pTo (Os.readLink fspathFrom pFrom)
+ | `FILE ->
+ debug (fun () -> Util.msg " Copying file %s / %s to %s / %s\n"
+ (Fspath.toDebugString fspathFrom) (Path.toString pFrom)
+ (Fspath.toDebugString fspathTo) (Path.toString pTo));
+ localFile fspathFrom pFrom fspathTo pTo pTo
+ `Copy info.Fileinfo.desc
+ (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) None
+ | `DIRECTORY ->
+ debug (fun () -> Util.msg " Copying directory %s / %s to %s / %s\n"
+ (Fspath.toDebugString fspathFrom) (Path.toString pFrom)
+ (Fspath.toDebugString fspathTo) (Path.toString pTo));
+ Os.createDir fspathTo pTo info.Fileinfo.desc;
+ let ch = Os.childrenOf fspathFrom pFrom in
+ Safelist.iter
+ (fun n -> copy (Path.child pFrom n) (Path.child pTo n)) ch
+ | `ABSENT -> assert false in
+ debug (fun () -> Util.msg " Copying recursively %s / %s\n"
+ (Fspath.toDebugString fspathFrom) (Path.toString pathFrom));
+ copy pathFrom pathTo;
+ debug (fun () -> Util.msg " Finished copying %s / %s\n"
+ (Fspath.toDebugString fspathFrom) (Path.toString pathTo))
Modified: trunk/src/copy.mli
===================================================================
--- trunk/src/copy.mli 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/copy.mli 2012-08-09 14:22:34 UTC (rev 505)
@@ -26,3 +26,10 @@
-> Uutil.Filesize.t (* fork length *)
-> Uutil.File.t option (* file's index in UI (for progress bars), if appropriate *)
-> unit
+
+val recursively :
+ Fspath.t (* fspath of source *)
+ -> Path.local (* path of source *)
+ -> Fspath.t (* fspath of target *)
+ -> Path.local (* path of target *)
+ -> unit
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/files.ml 2012-08-09 14:22:34 UTC (rev 505)
@@ -72,14 +72,52 @@
(* ------------------------------------------------------------ *)
-let deleteLocal (fspathTo, (pathTo, ui)) =
+let copyOnConflict = Prefs.createBool "copyonconflict" false
+ "!keep copies of conflicting files"
+ "When this flag is set, Unison will make a copy of files that would \
+ otherwise be overwritten or deleted in case of conflicting changes, \
+ and more generally whenever the default behavior is overriden. \
+ This makes it possible to automatically resolve conflicts in a \
+ fairly safe way when synchronizing continuously, in combination \
+ with the \\verb|-repeat watch| and \\verb|-prefer newer| preferences."
+
+let prepareCopy workingDir path notDefault =
+ if notDefault && Prefs.read copyOnConflict then begin
+ let tmpPath = Os.tempPath workingDir path in
+ Copy.recursively workingDir path workingDir tmpPath;
+ Some (workingDir, path, tmpPath)
+ end else
+ None
+
+let finishCopy copyInfo =
+ match copyInfo with
+ Some (workingDir, path, tmpPath) ->
+ let tm = Unix.localtime (Unix.gettimeofday ()) in
+ let rec copyPath n =
+ let p =
+ Path.addToFinalName path
+ (Format.sprintf " (copy: conflict%s on %04d-%02d-%02d)"
+ (if n = 0 then "" else " #" ^ string_of_int n)
+ (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday)
+ in
+ if Os.exists workingDir p then copyPath (n + 1) else p
+ in
+ Os.rename "keepCopy" workingDir tmpPath workingDir (copyPath 0)
+ | None ->
+ ()
+
+(* ------------------------------------------------------------ *)
+
+let deleteLocal (fspathTo, (pathTo, ui, notDefault)) =
debug (fun () ->
Util.msg "deleteLocal [%s] (None, %s)\n"
(Fspath.toDebugString fspathTo) (Path.toString pathTo));
let localPathTo = Update.translatePathLocal fspathTo pathTo in
+ let copyInfo = prepareCopy fspathTo localPathTo notDefault in
(* Make sure the target is unchanged first *)
(* (There is an unavoidable race condition here.) *)
let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in
+ finishCopy copyInfo;
Stasher.backup fspathTo localPathTo `AndRemove prevArch;
(* Archive update must be done last *)
Update.replaceArchiveLocal fspathTo localPathTo Update.NoArchive;
@@ -87,8 +125,8 @@
let deleteOnRoot = Remote.registerRootCmd "delete" deleteLocal
-let delete rootFrom pathFrom rootTo pathTo ui =
- deleteOnRoot rootTo (pathTo, ui) >>= fun _ ->
+let delete rootFrom pathFrom rootTo pathTo ui notDefault =
+ deleteOnRoot rootTo (pathTo, ui, notDefault) >>= fun _ ->
Update.replaceArchive rootFrom pathFrom Update.NoArchive
(* ------------------------------------------------------------ *)
@@ -268,10 +306,13 @@
temp file into place, but remain able to roll back if something fails
either locally or on the other side. *)
let renameLocal
- (fspathTo, (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt)) =
+ (fspathTo,
+ (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt, notDefault)) =
+ let copyInfo = prepareCopy workingDir pathTo notDefault in
(* Make sure the target is unchanged, then do the rename.
(Note that there is an unavoidable race condition here...) *)
let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in
+ finishCopy copyInfo;
performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch;
begin match archOpt with
Some archTo -> Stasher.stashCurrentVersion fspathTo localPathTo None;
@@ -285,12 +326,13 @@
let renameOnHost = Remote.registerRootCmd "rename" renameLocal
-let rename root localPath workingDir pathOld pathNew ui archOpt =
+let rename root localPath workingDir pathOld pathNew ui archOpt notDefault =
debug (fun() ->
Util.msg "rename(root=%s, pathOld=%s, pathNew=%s)\n"
(root2string root)
(Path.toString pathOld) (Path.toString pathNew));
- renameOnHost root (localPath, workingDir, pathOld, pathNew, ui, archOpt)
+ renameOnHost root
+ (localPath, workingDir, pathOld, pathNew, ui, archOpt, notDefault)
(* ------------------------------------------------------------ *)
@@ -431,6 +473,7 @@
this updateItem still describes the current
state of the target replica) *)
propsTo (* the properties of the parent directories *)
+ notDefault (* [true] if not Unison's default action *)
id = (* for progress display *)
debug (fun() ->
Util.msg
@@ -564,7 +607,7 @@
(* Rename the files to their final location and then update the
archive on the destination replica *)
rename rootTo localPathTo workingDir tempPathTo realPathTo uiTo
- (Some archTo) >>= fun () ->
+ (Some archTo) notDefault >>= fun () ->
(* Update the archive on the source replica
FIX: we could reuse localArch if rootFrom is the same as rootLocal *)
updateSourceArchive rootFrom (localPathFrom, uiFrom, errPaths) >>= fun () ->
@@ -748,7 +791,7 @@
(Local, fspathFrom) pathFrom rootTo workingDirForCopy tempPathTo realPathTo
`Copy newprops fp None stamp id >>= fun info ->
rename rootTo localPathTo workingDirForCopy tempPathTo realPathTo
- uiTo None)
+ uiTo None false)
let keeptempfilesaftermerge =
Prefs.createBool
Modified: trunk/src/files.mli
===================================================================
--- trunk/src/files.mli 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/files.mli 2012-08-09 14:22:34 UTC (rev 505)
@@ -11,6 +11,7 @@
-> Common.root (* root *)
-> Path.t (* path to delete *)
-> Common.updateItem (* updates that will be discarded *)
+ -> bool (* [true] if not Unison's default action *)
-> unit Lwt.t
(* Region used for the copying. Exported to be correctly set in transport.ml *)
@@ -31,6 +32,7 @@
-> Path.t (* to what path *)
-> Common.updateItem (* dest. updates *)
-> Props.t list (* properties of parent directories *)
+ -> bool (* [true] if not Unison's default action *)
-> Uutil.File.t (* id for showing progress of transfer *)
-> unit Lwt.t
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/mkProjectInfo.ml 2012-08-09 14:22:34 UTC (rev 505)
@@ -79,3 +79,4 @@
+
Modified: trunk/src/path.ml
===================================================================
--- trunk/src/path.ml 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/path.ml 2012-08-09 14:22:34 UTC (rev 505)
@@ -188,6 +188,14 @@
let addSuffixToFinalName path suffix = path ^ suffix
+let addToFinalName path suffix =
+ let l = String.length path in
+ assert (l > 0);
+ let i = try String.rindex path '/' with Not_found -> -1 in
+ let j = try String.rindex path '.' with Not_found -> -1 in
+ let j = if j <= i then l else j in
+ String.sub path 0 j ^ suffix ^ String.sub path j (l - j)
+
let addPrefixToFinalName path prefix =
try
let i = String.rindex path pathSeparatorChar + 1 in
Modified: trunk/src/path.mli
===================================================================
--- trunk/src/path.mli 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/path.mli 2012-08-09 14:22:34 UTC (rev 505)
@@ -29,6 +29,8 @@
val addSuffixToFinalName : local -> string -> local
val addPrefixToFinalName : local -> string -> local
+val addToFinalName : local -> string -> local
+ (* Add to the final name, but before any file extension. *)
val compare : t -> t -> int
val equal : local -> local -> bool
Modified: trunk/src/stasher.ml
===================================================================
--- trunk/src/stasher.ml 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/stasher.ml 2012-08-09 14:22:34 UTC (rev 505)
@@ -382,32 +382,7 @@
(Fspath.toDebugString fspath) (Path.toString path)
(Path.toString backPath) (Fspath.toDebugString backRoot));
let byCopying() =
- let rec copy p backp =
- let info = Fileinfo.get true fspath p in
- match info.Fileinfo.typ with
- | `SYMLINK ->
- debug (fun () -> Util.msg " Copying link %s / %s to %s / %s\n"
- (Fspath.toDebugString fspath) (Path.toString p)
- (Fspath.toDebugString backRoot) (Path.toString backp));
- Os.symlink backRoot backp (Os.readLink fspath p)
- | `FILE ->
- debug (fun () -> Util.msg " Copying file %s / %s to %s / %s\n"
- (Fspath.toDebugString fspath) (Path.toString p)
- (Fspath.toDebugString backRoot) (Path.toString backp));
- Copy.localFile fspath p backRoot backp backp
- `Copy info.Fileinfo.desc
- (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) None
- | `DIRECTORY ->
- debug (fun () -> Util.msg " Copying directory %s / %s to %s / %s\n"
- (Fspath.toDebugString fspath) (Path.toString p)
- (Fspath.toDebugString backRoot) (Path.toString backp));
- Os.createDir backRoot backp info.Fileinfo.desc;
- let ch = Os.childrenOf fspath p in
- Safelist.iter (fun n -> copy (Path.child p n) (Path.child backp n)) ch
- | `ABSENT -> assert false in
- copy path backPath;
- debug (fun () -> Util.msg " Finished copying; deleting %s / %s\n"
- (Fspath.toDebugString fspath) (Path.toString path));
+ Copy.recursively fspath path backRoot backPath;
disposeIfNeeded() in
begin if finalDisposition = `AndRemove then
try
Modified: trunk/src/transport.ml
===================================================================
--- trunk/src/transport.ml 2012-08-09 14:06:21 UTC (rev 504)
+++ trunk/src/transport.ml 2012-08-09 14:22:34 UTC (rev 505)
@@ -77,7 +77,8 @@
(fun _ ->
Printf.sprintf "[END] %s\n" lwtShortDescription)
-let doAction fromRoot fromPath fromContents toRoot toPath toContents id =
+let doAction
+ fromRoot fromPath fromContents toRoot toPath toContents notDefault id =
(* When streaming, we can transfer many file simultaneously:
as the contents of only one file is transferred in one direction
at any time, little resource is consumed this way. *)
@@ -98,7 +99,8 @@
("Deleting " ^ Path.toString toPath ^
"\n from "^ root2string toRoot)
("Deleting " ^ Path.toString toPath)
- (fun () -> Files.delete fromRoot fromPath toRoot toPath uiTo)
+ (fun () ->
+ Files.delete fromRoot fromPath toRoot toPath uiTo notDefault)
(* No need to transfer the whole directory/file if there were only
property modifications on one side. (And actually, it would be
incorrect to transfer a directory in this case.) *)
@@ -120,7 +122,8 @@
("Updating file " ^ Path.toString toPath)
(fun () ->
Files.copy (`Update (fileSize uiFrom uiTo))
- fromRoot fromPath uiFrom [] toRoot toPath uiTo [] id)
+ fromRoot fromPath uiFrom [] toRoot toPath uiTo []
+ notDefault id)
| {ui = uiFrom; props = propsFrom}, {ui = uiTo; props = propsTo} ->
logLwtNumbered
("Copying " ^ Path.toString toPath ^ "\n from " ^
@@ -130,7 +133,8 @@
(fun () ->
Files.copy `Copy
fromRoot fromPath uiFrom propsFrom
- toRoot toPath uiTo propsTo id))
+ toRoot toPath uiTo propsTo
+ notDefault id))
(fun e -> Trace.log
(Printf.sprintf
"Failed: %s\n" (Util.printException e));
@@ -143,16 +147,20 @@
Trace.log (Printf.sprintf "[ERROR] Skipping %s\n %s\n"
(Path.toString path) p);
return ()
- | Different {rc1 = rc1; rc2 = rc2; direction = dir} ->
+ | Different
+ {rc1 = rc1; rc2 = rc2; direction = dir; default_direction = def} ->
+ let notDefault = dir <> def in
match dir with
Conflict ->
Trace.log (Printf.sprintf "[CONFLICT] Skipping %s\n"
(Path.toString path));
return ()
| Replica1ToReplica2 ->
- doAction root1 reconItem.path1 rc1 root2 reconItem.path2 rc2 id
+ doAction
+ root1 reconItem.path1 rc1 root2 reconItem.path2 rc2 notDefault id
| Replica2ToReplica1 ->
- doAction root2 reconItem.path2 rc2 root1 reconItem.path1 rc1 id
+ doAction
+ root2 reconItem.path2 rc2 root1 reconItem.path1 rc1 notDefault id
| Merge ->
if rc1.typ <> `FILE || rc2.typ <> `FILE then
raise (Util.Transient "Can only merge two existing files");
More information about the Unison-hackers
mailing list