summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJérôme Vouillon <vouillon@pps.jussieu.fr>2009-07-10 19:51:15 +0000
committerJérôme Vouillon <vouillon@pps.jussieu.fr>2009-07-10 19:51:15 +0000
commit005a53075b998dba27eeff74a1fc8f9d73558fb8 (patch)
treed81d2687b5f96bd57b9b86e5ebd50ed172794a33
parent59e44114fd936c3f53f1d39c6cf442f5921bc243 (diff)
downloadunison-005a53075b998dba27eeff74a1fc8f9d73558fb8.zip
unison-005a53075b998dba27eeff74a1fc8f9d73558fb8.tar.gz
unison-005a53075b998dba27eeff74a1fc8f9d73558fb8.tar.bz2
* Fixed bug with case insensitive mode on a case sensitive filesystem:
- if file "a/a" is created on one replica and directory "A" is created on the other, the file failed to be synchronized the first time Unison is run afterwards, as Unison uses the wrong path "a/a" (if Unison is run again, the directories are in the archive, so the right path is used); - if file "a" appears on one replica and file "A" appears on the other with a different contents, Unison was unable to synchronized them.
-rw-r--r--src/RECENTNEWS13
-rw-r--r--src/common.ml4
-rw-r--r--src/common.mli4
-rw-r--r--src/files.ml34
-rw-r--r--src/files.mli5
-rw-r--r--src/mkProjectInfo.ml1
-rw-r--r--src/recon.ml83
-rw-r--r--src/recon.mli2
-rw-r--r--src/sortri.ml8
-rw-r--r--src/transport.ml48
-rw-r--r--src/uicommon.ml7
-rw-r--r--src/uigtk2.ml30
-rw-r--r--src/uimacbridgenew.ml25
-rw-r--r--src/uitext.ml16
-rw-r--r--src/update.ml22
-rw-r--r--src/update.mli7
16 files changed, 164 insertions, 145 deletions
diff --git a/src/RECENTNEWS b/src/RECENTNEWS
index fe6fdd0..7286c11 100644
--- a/src/RECENTNEWS
+++ b/src/RECENTNEWS
@@ -1,5 +1,18 @@
CHANGES FROM VERSION 2.36.-27
+* Fixed bug with case insensitive mode on a case sensitive filesystem:
+ - if file "a/a" is created on one replica and directory "A" is
+ created on the other, the file failed to be synchronized the first
+ time Unison is run afterwards, as Unison uses the wrong path "a/a"
+ (if Unison is run again, the directories are in the archive, so
+ the right path is used);
+ - if file "a" appears on one replica and file "A" appears on the
+ other with a different contents, Unison was unable to synchronized
+ them.
+
+-------------------------------
+CHANGES FROM VERSION 2.36.-27
+
* Accurate computation of the amount of data to transfer
* Accurate update of the amount of data transferred, including:
- when transferring by copying on the remote host
diff --git a/src/common.ml b/src/common.ml
index bd3763c..b10cfa5 100644
--- a/src/common.ml
+++ b/src/common.ml
@@ -140,9 +140,7 @@ type replicas =
Problem of string (* There was a problem during update detection *)
| Different of difference (* Replicas differ *)
-type reconItem =
- {path : Path.t;
- replicas : replicas}
+type reconItem = {path1 : Path.t; path2 : Path.t; replicas : replicas}
let ucLength = function
File(desc,_) -> Props.length desc
diff --git a/src/common.mli b/src/common.mli
index d0c08ad..9cef032 100644
--- a/src/common.mli
+++ b/src/common.mli
@@ -117,9 +117,7 @@ type replicas =
| Different of difference (* Replicas differ *)
(* Variable name prefix: "ri" *)
-type reconItem =
- {path : Path.t;
- replicas : replicas}
+type reconItem = {path1 : Path.t; path2 : Path.t; replicas : replicas}
val ucLength : updateContent -> Uutil.Filesize.t
val uiLength : updateItem -> Uutil.Filesize.t
diff --git a/src/files.ml b/src/files.ml
index 9999519..a41119a 100644
--- a/src/files.ml
+++ b/src/files.ml
@@ -699,20 +699,20 @@ let showStatus = function
| Unix.WSIGNALED i -> Printf.sprintf "killed with signal %d" i
| Unix.WSTOPPED i -> Printf.sprintf "stopped with signal %d" i
-let merge root1 root2 path id ui1 ui2 showMergeFn =
+let merge root1 path1 ui1 root2 path2 ui2 id showMergeFn =
debug (fun () -> Util.msg "merge path %s between roots %s and %s\n"
- (Path.toString path) (root2string root1) (root2string root2));
+ (Path.toString path1) (root2string root1) (root2string root2));
(* The following assumes root1 is always local: switch them if needed to make this so *)
- let (root1,root2) =
+ let (root1,path1,ui1,root2,path2,ui2) =
match root1 with
- (Local,fspath1) -> (root1,root2)
- | _ -> (root2,root1) in
+ (Local,fspath1) -> (root1,path1,ui1,root2,path2,ui2)
+ | _ -> (root2,path2,ui2,root1,path1,ui1) in
let (localPath1, (workingDirForMerge, basep), fspath1) =
match root1 with
(Local,fspath1) ->
- let localPath1 = Update.translatePathLocal fspath1 path in
+ let localPath1 = Update.translatePathLocal fspath1 path1 in
(localPath1, Fspath.findWorkingDir fspath1 localPath1, fspath1)
| _ -> assert false in
@@ -754,9 +754,9 @@ let merge root1 root2 path id ui1 ui2 showMergeFn =
`Copy desc1 fp1 None ress1 id >>= fun info ->
Lwt.return ());
Lwt_unix.run
- (Update.translatePath root2 path >>= (fun path ->
+ (Update.translatePath root2 path2 >>= (fun path2 ->
Copy.file
- root2 path root1 workingDirForMerge working2 basep
+ root2 path2 root1 workingDirForMerge working2 basep
`Copy desc2 fp2 None ress2 id) >>= fun info ->
Lwt.return ());
@@ -805,7 +805,7 @@ let merge root1 root2 path id ui1 ui2 showMergeFn =
let info2 = Fileinfo.get false workingDirForMerge working2 in
let dig2 = Os.fingerprint workingDirForMerge working2 info2 in
let cmd = formatMergeCmd
- path
+ path1
(Fspath.quotes (Fspath.concat workingDirForMerge working1))
(Fspath.quotes (Fspath.concat workingDirForMerge working2))
(match arch with None -> None | Some f -> Some(Fspath.quotes f))
@@ -828,7 +828,7 @@ let merge root1 root2 path id ui1 ui2 showMergeFn =
the displaying from the querying... *)
if not
(showMergeFn
- (Printf.sprintf "Results of merging %s" (Path.toString path))
+ (Printf.sprintf "Results of merging %s" (Path.toString path1))
mergeResultLog) then
raise (Util.Transient ("Merge command canceled by the user"));
@@ -946,14 +946,14 @@ let merge root1 root2 path id ui1 ui2 showMergeFn =
Lwt_unix.run
(debug (fun () -> Util.msg "Committing results of merge\n");
- copyBack workingDirForMerge working1 root1 path desc1 ui1 id >>= (fun () ->
- copyBack workingDirForMerge working2 root2 path desc2 ui2 id >>= (fun () ->
+ copyBack workingDirForMerge working1 root1 path1 desc1 ui1 id >>= (fun () ->
+ copyBack workingDirForMerge working2 root2 path2 desc2 ui2 id >>= (fun () ->
let arch_fspath = Fspath.concat workingDirForMerge workingarch in
if Fs.file_exists arch_fspath then begin
debug (fun () -> Util.msg "Updating unison archives for %s to reflect results of merge\n"
- (Path.toString path));
- if not (Stasher.shouldBackupCurrent path) then
- Util.msg "Warning: 'backupcurrent' is not set for path %s\n" (Path.toString path);
+ (Path.toString path1));
+ if not (Stasher.shouldBackupCurrent path1) then
+ 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
@@ -963,8 +963,8 @@ let merge root1 root2 path id ui1 ui2 showMergeFn =
(Props.get (Fs.stat arch_fspath) infoarch.osX, dig,
Fileinfo.stamp (Fileinfo.get true arch_fspath Path.empty),
Osx.stamp infoarch.osX) in
- Update.replaceArchive root1 path new_archive_entry >>= fun _ ->
- Update.replaceArchive root2 path new_archive_entry >>= fun _ ->
+ Update.replaceArchive root1 path1 new_archive_entry >>= fun _ ->
+ Update.replaceArchive root2 path2 new_archive_entry >>= fun _ ->
Lwt.return ()
end else
(Lwt.return ()) )))) )
diff --git a/src/files.mli b/src/files.mli
index b75c724..e3ba168 100644
--- a/src/files.mli
+++ b/src/files.mli
@@ -68,11 +68,12 @@ val ls : System.fspath -> string -> string list
val merge :
Common.root (* first root *)
+ -> Path.t (* path to merge *)
+ -> Common.updateItem (* differences from the archive *)
-> Common.root (* second root *)
-> Path.t (* path to merge *)
- -> Uutil.File.t (* id for showing progress of transfer *)
-> Common.updateItem (* differences from the archive *)
- -> Common.updateItem (* ... *)
+ -> Uutil.File.t (* id for showing progress of transfer *)
-> (string->string->bool) (* function to display the (title and) result
and ask user for confirmation (when -batch
is true, the function should not ask any
diff --git a/src/mkProjectInfo.ml b/src/mkProjectInfo.ml
index c3b780f..395cb3e 100644
--- a/src/mkProjectInfo.ml
+++ b/src/mkProjectInfo.ml
@@ -87,3 +87,4 @@ Printf.printf "MAJORVERSION=%d.%d\n" majorVersion minorVersion;;
Printf.printf "VERSION=%d.%d.%d\n" majorVersion minorVersion pointVersion;;
Printf.printf "NAME=%s\n" projectName;;
+
diff --git a/src/recon.ml b/src/recon.ml
index c959670..40281f5 100644
--- a/src/recon.ml
+++ b/src/recon.ml
@@ -33,7 +33,7 @@ let setDirection ri dir force =
else if dir=`Replica2ToReplica1 then
diff.direction <- Replica2ToReplica1
else if dir=`Merge then begin
- if Globals.shouldMerge ri.path then diff.direction <- Merge
+ if Globals.shouldMerge ri.path1 then diff.direction <- Merge
end else (* dir = `Older or dir = `Newer *)
if rc1.status<>`Deleted && rc2.status<>`Deleted then begin
let comp = Props.time rc1.desc -. Props.time rc2.desc in
@@ -167,7 +167,7 @@ let overrideReconcilerChoices ris =
Safelist.iter (fun ri -> setDirection ri dir force) ris
end;
Safelist.iter (fun ri ->
- let (rootp,forcep) = lookupPreferredRootPartial ri.path in
+ let (rootp,forcep) = lookupPreferredRootPartial ri.path1 in
if rootp<>"" then begin
let dir = root2direction rootp in
setDirection ri dir forcep
@@ -312,8 +312,8 @@ let describeUpdate path ui
(* this out into a separate function to avoid duplicating all the symmetric *)
(* cases.) *)
let rec reconcileNoConflict allowPartial path ui whatIsUpdated
- (result: (Name.t, Common.replicas) Tree.u)
- : (Name.t, Common.replicas) Tree.u =
+ (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
match whatIsUpdated with
@@ -340,7 +340,7 @@ let rec reconcileNoConflict allowPartial path ui whatIsUpdated
(fun result (theName, uiChild) ->
Tree.leave
(reconcileNoConflict allowPartial (Path.child path theName)
- uiChild whatIsUpdated (Tree.enter result theName)))
+ uiChild whatIsUpdated (Tree.enter result (theName, theName))))
r children
| Updates _ ->
Tree.add result (propagateErrors allowPartial (different ()))
@@ -355,19 +355,19 @@ let combineChildren children1 children2 =
[],_ ->
Safelist.rev_append r
(Safelist.map
- (fun (name,ui) -> (name,NoUpdates,ui)) children2)
+ (fun (name,ui) -> (name,NoUpdates,name,ui)) children2)
| _,[] ->
Safelist.rev_append r
(Safelist.map
- (fun (name,ui) -> (name,ui,NoUpdates)) children1)
+ (fun (name,ui) -> (name,ui,name,NoUpdates)) children1)
| (name1,ui1)::rem1, (name2,ui2)::rem2 ->
let dif = Name.compare name1 name2 in
if dif = 0 then
- loop ((name1,ui1,ui2)::r) rem1 rem2
+ loop ((name1,ui1,name2,ui2)::r) rem1 rem2
else if dif < 0 then
- loop ((name1,ui1,NoUpdates)::r) rem1 children2
+ loop ((name1,ui1,name1,NoUpdates)::r) rem1 children2
else
- loop ((name2,NoUpdates,ui2)::r) children1 rem2
+ loop ((name2,NoUpdates,name2,ui2)::r) children1 rem2
in
loop [] children1 children2
@@ -389,11 +389,11 @@ let add_equal (counter, archiveUpdated) equal v =
(* propagating changes to make the two replicas equal. *)
(* -- *)
(* It uses two accumulators: *)
-(* equals: (Name.t, Common.updateContent * Common.updateContent) *)
+(* equals: (Name.t * Name.t, Common.updateContent * Common.updateContent) *)
(* Tree.u *)
-(* unequals: (Name.t, Common.replicas) Tree.u *)
+(* unequals: (Name.t * Name.t, Common.replicas) Tree.u *)
(* -- *)
-let rec reconcile allowPartial path ui1 ui2 counter equals unequals =
+let rec reconcile allowPartial path ui1 ui2 counter (equals:(_*_,_)Tree.u) unequals =
let different uc1 uc2 oldType equals unequals =
(equals,
Tree.add unequals
@@ -446,10 +446,11 @@ let rec reconcile allowPartial path ui1 ui2 counter equals unequals =
in
(* Apply reconcile on children. *)
Safelist.fold_left
- (fun (equals, unequals) (name,ui1,ui2) ->
+ (fun (equals, unequals) (name1,ui1,name2,ui2) ->
let (eq, uneq) =
- reconcile allowPartial (Path.child path name) ui1 ui2 counter
- (Tree.enter equals name) (Tree.enter unequals name)
+ reconcile allowPartial (Path.child path name1) ui1 ui2 counter
+ (Tree.enter equals (name1, name2))
+ (Tree.enter unequals (name1, name2))
in
(Tree.leave eq, Tree.leave uneq))
dirResult
@@ -492,10 +493,14 @@ let sortPaths pathUpdatesList =
(fun (p1, _) (p2, _) -> Path.compare p1 p2 <= 0)
pathUpdatesList
-let rec enterPath p t =
- match Path.deconstruct p with
- None -> t
- | Some (nm, p') -> enterPath p' (Tree.enter t nm)
+let rec enterPath p1 p2 t =
+ match Path.deconstruct p1, Path.deconstruct p2 with
+ None, None ->
+ t
+ | Some (nm1, p1'), Some (nm2, p2') ->
+ enterPath p1' p2' (Tree.enter t (nm1, nm2))
+ | _ ->
+ assert false (* Cannot happen, as the paths are equal up to case *)
let rec leavePath p t =
match Path.deconstruct p with
@@ -515,23 +520,22 @@ let dangerousPath u1 u2 =
(* The second component of the return value is true if there is at least one *)
(* file that is updated in the same way on both roots *)
let reconcileList allowPartial
- (pathUpdatesList: (Path.t * Common.updateItem list) list)
+ (pathUpdatesList:
+ (Path.t * Common.updateItem * Path.t * Common.updateItem) 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) (path,updatesList) ->
- match updatesList with
- [ui1; ui2] ->
- let (equals, unequals) =
- reconcile allowPartial path ui1 ui2 (counter, archiveUpdated)
- (enterPath path equals) (enterPath path unequals)
- in
- (leavePath path equals, leavePath path unequals,
- if dangerousPath ui1 ui2 then path :: dangerous else dangerous)
- | _ ->
- assert false)
+ (fun (equals, unequals, dangerous) (path1,ui1,path2,ui2) ->
+ let (equals, unequals) =
+ reconcile allowPartial
+ path1 ui1 ui2 (counter, archiveUpdated)
+ (enterPath path1 path2 equals)
+ (enterPath path1 path2 unequals)
+ in
+ (leavePath path1 equals, leavePath path1 unequals,
+ if dangerousPath ui1 ui2 then path1 :: dangerous else dangerous))
(Tree.start, Tree.start, []) pathUpdatesList in
let unequals = Tree.finish unequals in
debug (fun() -> Util.msg "reconcile: %d results\n" (Tree.size unequals));
@@ -539,9 +543,13 @@ let reconcileList allowPartial
Update.markEqual equals;
(* Commit archive updates done up to now *)
if !archiveUpdated then Update.commitUpdates ();
- let result = Tree.flatten unequals Path.empty Path.child [] in
+ let result =
+ Tree.flatten unequals (Path.empty, Path.empty)
+ (fun (p1, p2) (nm1, nm2) -> (Path.child p1 nm1, Path.child p2 nm2)) [] in
let unsorted =
- Safelist.map (fun (p, rplc) -> {path = p; replicas = rplc}) result in
+ Safelist.map
+ (fun ((p1, p2), rplc) -> {path1 = p1; path2 = p2; replicas = rplc})
+ result in
let sorted = Sortri.sortReconItems unsorted in
overrideReconcilerChoices sorted;
(sorted, not (Tree.is_empty equals), dangerous)
@@ -550,10 +558,7 @@ let reconcileList allowPartial
according to the roots and paths of synchronization, builds the
corresponding reconItem list. A second component indicates whether there
is any file updated in the same way on both sides. *)
-let reconcileAll ?(allowPartial = false) (ONEPERPATH(updatesListList)) =
+let reconcileAll ?(allowPartial = false) updatesList =
Trace.status "Reconciling changes";
debug (fun() -> Util.msg "reconcileAll\n");
- let pathList = Prefs.read Globals.paths in
- let pathUpdatesList =
- sortPaths (Safelist.combine pathList updatesListList) in
- reconcileList allowPartial pathUpdatesList
+ reconcileList allowPartial updatesList
diff --git a/src/recon.mli b/src/recon.mli
index 42fcfad..a924965 100644
--- a/src/recon.mli
+++ b/src/recon.mli
@@ -4,7 +4,7 @@
val reconcileAll :
?allowPartial:bool (* whether we allow partial synchronization
of directories (default to false) *)
- -> Common.updateItem list Common.oneperpath
+ -> (Path.t * Common.updateItem * Path.t * Common.updateItem) list
(* one updateItem per replica, per path *)
-> Common.reconItem list (* List of updates that need propagated *)
* bool (* Any file updated equally on all roots*)
diff --git a/src/sortri.ml b/src/sortri.ml
index 00a7be2..c6da19b 100644
--- a/src/sortri.ml
+++ b/src/sortri.ml
@@ -100,9 +100,9 @@ let sortNewFirst () =
(* Main sorting functions *)
let shouldSortFirst ri =
- Pred.test sortfirst (Path.toString ri.path)
+ Pred.test sortfirst (Path.toString ri.path1)
let shouldSortLast ri =
- Pred.test sortlast (Path.toString ri.path)
+ Pred.test sortlast (Path.toString ri.path1)
let newItem ri =
let newItem1 ri =
@@ -139,10 +139,10 @@ let compareReconItems () =
let l2 = Common.riLength ri2 in
if l1<l2 then -1 else if l2<l1 then 1 else 0
else 0);
- (compare (Path.toString ri1.path) (Path.toString ri2.path))
+ (compare (Path.toString ri1.path1) (Path.toString ri2.path1))
] in
dbgsort (fun() -> Util.msg "%s <= %s --> %d\n"
- (Path.toString ri1.path) (Path.toString ri2.path) cmp);
+ (Path.toString ri1.path1) (Path.toString ri2.path1) cmp);
cmp
let sortReconItems items = Safelist.stable_sort (compareReconItems()) items
diff --git a/src/transport.ml b/src/transport.ml
index 4f33410..3bbc0b1 100644
--- a/src/transport.ml
+++ b/src/transport.ml
@@ -75,7 +75,7 @@ let logLwtNumbered (lwtDescription: string) (lwtShortDescription: string)
(fun _ ->
Printf.sprintf "[END] %s\n" lwtShortDescription)
-let doAction (fromRoot,toRoot) path fromContents toContents id =
+let doAction fromRoot fromPath fromContents toRoot toPath toContents id =
Lwt_util.resize_region actionReg (Prefs.read maxthreads);
(* When streaming, we can transfer many file simultaneously:
as the contents of only one file is transferred in one direction
@@ -85,53 +85,53 @@ let doAction (fromRoot,toRoot) path fromContents toContents id =
Prefs.read maxthreads);
Lwt_util.run_in_region actionReg 1 (fun () ->
if not !Trace.sendLogMsgsToStderr then
- Trace.statusDetail (Path.toString path);
+ Trace.statusDetail (Path.toString toPath);
Remote.Thread.unwindProtect (fun () ->
match fromContents, toContents with
{typ = `ABSENT}, {ui = uiTo} ->
logLwtNumbered
- ("Deleting " ^ Path.toString path ^
+ ("Deleting " ^ Path.toString toPath ^
"\n from "^ root2string toRoot)
- ("Deleting " ^ Path.toString path)
- (fun () -> Files.delete fromRoot path toRoot path uiTo)
+ ("Deleting " ^ Path.toString toPath)
+ (fun () -> Files.delete fromRoot fromPath toRoot toPath uiTo)
(* 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.) *)
| {status= `Unchanged | `PropsChanged; desc= fromProps; ui= uiFrom},
{status= `Unchanged | `PropsChanged; desc= toProps; ui = uiTo} ->
logLwtNumbered
- ("Copying properties for " ^ Path.toString path
+ ("Copying properties for " ^ Path.toString toPath
^ "\n from " ^ root2string fromRoot ^ "\n to " ^
root2string toRoot)
- ("Copying properties for " ^ Path.toString path)
+ ("Copying properties for " ^ Path.toString toPath)
(fun () ->
Files.setProp
- fromRoot path toRoot path fromProps toProps uiFrom uiTo)
+ fromRoot fromPath toRoot toPath fromProps toProps uiFrom uiTo)
| {typ = `FILE; ui = uiFrom}, {typ = `FILE; ui = uiTo} ->
logLwtNumbered
- ("Updating file " ^ Path.toString path ^ "\n from " ^
+ ("Updating file " ^ Path.toString toPath ^ "\n from " ^
root2string fromRoot ^ "\n to " ^
root2string toRoot)
- ("Updating file " ^ Path.toString path)
+ ("Updating file " ^ Path.toString toPath)
(fun () ->
Files.copy (`Update (fileSize uiFrom uiTo))
- fromRoot path uiFrom toRoot path uiTo id)
+ fromRoot fromPath uiFrom toRoot toPath uiTo id)
| {ui = uiFrom}, {ui = uiTo} ->
logLwtNumbered
- ("Copying " ^ Path.toString path ^ "\n from " ^
+ ("Copying " ^ Path.toString toPath ^ "\n from " ^
root2string fromRoot ^ "\n to " ^
root2string toRoot)
- ("Copying " ^ Path.toString path)
+ ("Copying " ^ Path.toString toPath)
(fun () ->
Files.copy `Copy
- fromRoot path uiFrom toRoot path uiTo id))
+ fromRoot fromPath uiFrom toRoot toPath uiTo id))
(fun e -> Trace.log
(Printf.sprintf
"Failed: %s\n" (Util.printException e));
return ()))
let propagate root1 root2 reconItem id showMergeFn =
- let path = reconItem.path in
+ let path = reconItem.path1 in
match reconItem.replicas with
Problem p ->
Trace.log (Printf.sprintf "[ERROR] Skipping %s\n %s\n"
@@ -144,16 +144,16 @@ let propagate root1 root2 reconItem id showMergeFn =
(Path.toString path));
return ()
| Replica1ToReplica2 ->
- doAction (root1, root2) path rc1 rc2 id
+ doAction root1 reconItem.path1 rc1 root2 reconItem.path2 rc2 id
| Replica2ToReplica1 ->
- doAction (root2, root1) path rc2 rc1 id
- | Merge ->
- begin match (rc1,rc2) with
- {typ = `FILE; ui = ui1}, {typ = `FILE; ui = ui2} ->
- Files.merge root1 root2 path id ui1 ui2 showMergeFn;
- return ()
- | _ -> raise (Util.Transient "Can only merge two existing files")
- end
+ doAction root2 reconItem.path2 rc2 root1 reconItem.path1 rc1 id
+ | Merge ->
+ if rc1.typ <> `FILE || rc2.typ <> `FILE then
+ raise (Util.Transient "Can only merge two existing files");
+ Files.merge
+ root1 reconItem.path1 rc1.ui root2 reconItem.path2 rc2.ui id
+ showMergeFn;
+ return ()
let transportItem reconItem id showMergeFn =
let (root1,root2) = Globals.roots() in
diff --git a/src/uicommon.ml b/src/uicommon.ml
index 39850de..5167a14 100644
--- a/src/uicommon.ml
+++ b/src/uicommon.ml
@@ -309,13 +309,13 @@ let action2niceString action =
let reconItem2stringList oldPath theRI =
match theRI.replicas with
Problem s ->
- (" ", AError, " ", displayPath oldPath theRI.path)
+ (" ", AError, " ", displayPath oldPath theRI.path1)
| Different diff ->
let partial = diff.errors1 <> [] || diff.errors2 <> [] in
(replicaContent2shortString diff.rc1,
direction2action partial diff.direction,
replicaContent2shortString diff.rc2,
- displayPath oldPath theRI.path)
+ displayPath oldPath theRI.path1)
let reconItem2string oldPath theRI status =
let (r1, action, r2, path) = reconItem2stringList oldPath theRI in
@@ -329,7 +329,6 @@ let exn2string = function
(* precondition: uc = File (Updates(_, ..) on both sides *)
let showDiffs ri printer errprinter id =
- let p = ri.path in
match ri.replicas with
Problem _ ->
errprinter
@@ -337,7 +336,7 @@ let showDiffs ri printer errprinter id =
| Different {rc1 = {typ = `FILE; ui = ui1}; rc2 = {typ = `FILE; ui = ui2}} ->
let (root1,root2) = Globals.roots() in
begin
- try Files.diff root1 p ui1 root2 p ui2 printer id
+ try Files.diff root1 ri.path1 ui1 root2 ri.path2 ui2 printer id
with Util.Transient e -> errprinter e
end
| Different _ ->
diff --git a/src/uigtk2.ml b/src/uigtk2.ml
index 48589af..a6fd819 100644
--- a/src/uigtk2.ml
+++ b/src/uigtk2.ml
@@ -1343,14 +1343,13 @@ let rec createToplevelWindow () =
None ->
None
| Some row ->
+ let path = Path.toString !theState.(row).ri.path1 in
match !theState.(row).whatHappened with
Some (Util.Failed _, Some det) ->
- let path = Path.toString !theState.(row).ri.path in
Some ("Merge execution details for file" ^
transcodeFilename path,
det)
| _ ->
- let path = Path.toString !theState.(row).ri.path in
match !theState.(row).ri.replicas with
Problem err ->
Some ("Errors for file " ^ transcodeFilename path, err)
@@ -1451,8 +1450,8 @@ let rec createToplevelWindow () =
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
- let path = Path.toString !theState.(row).ri.path in
+ | Some(Util.Failed(s), Some resultLog) -> 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 =
@@ -1522,7 +1521,7 @@ let rec createToplevelWindow () =
if !current=None then nextInteresting () in
let columnsOf i =
- let oldPath = if i = 0 then Path.empty else !theState.(i-1).ri.path in
+ let oldPath = if i = 0 then Path.empty else !theState.(i-1).ri.path1 in
let status =
match !theState.(i).ri.replicas with
Different {direction = Conflict} | Problem _ ->
@@ -1735,7 +1734,7 @@ lst_store#set ~row ~column:c_path path;
let ignoreAndRedisplay () =
let lst = Array.to_list !theState in
(* FIX: we should actually test whether any prefix is now ignored *)
- let keep sI = not (Globals.shouldIgnore sI.ri.path) in
+ let keep sI = not (Globals.shouldIgnore sI.ri.path1) in
begin match !current with
None ->
theState := Array.of_list (Safelist.filter keep lst)
@@ -1842,7 +1841,7 @@ lst_store#set ~row ~column:c_path path;
let addRegExpByPath pathfunc =
match !current with
Some i ->
- Uicommon.addIgnorePattern (pathfunc !theState.(i).ri.path);
+ Uicommon.addIgnorePattern (pathfunc !theState.(i).ri.path1);
ignoreAndRedisplay ()
| None ->
() in
@@ -1994,8 +1993,9 @@ lst_store#set ~row ~column:c_path path;
(fun l si ->
l + (match si.whatHappened with Some(Util.Failed(_), _) -> 1 | _ -> 0))
0 !theState in
- if count = 0 then "" else
- Printf.sprintf "%d failure%s" count (if count=1 then "" else "s") in
+ if count = 0 then [] else
+ [Printf.sprintf "%d failure%s" count (if count=1 then "" else "s")]
+ in
let partials =
let count =
Array.fold_left
@@ -2008,19 +2008,19 @@ lst_store#set ~row ~column:c_path path;
| _ ->
0)
0 !theState in
- if count = 0 then "" else
- Printf.sprintf "%d partially transferred" count in
+ if count = 0 then [] else
+ [Printf.sprintf "%d partially transferred" count] in
let skipped =
let count =
Array.fold_left
(fun l si ->
l + (if problematic si.ri then 1 else 0))
0 !theState in
- if count = 0 then "" else
- Printf.sprintf "%d skipped" count in
+ if count = 0 then [] else
+ [Printf.sprintf "%d skipped" count] in
Trace.status
(Printf.sprintf "Synchronization complete %s"
- (String.concat ", " [failures; partials; skipped]));
+ (String.concat ", " (failures @ partials @ skipped)));
displayGlobalProgress 0.;
grSet grRescan true
@@ -2378,7 +2378,7 @@ lst_store#set ~row ~column:c_path path;
else loop (i+1) (acc) in
let failedindices = loop 0 [] in
let failedpaths =
- Safelist.map (fun i -> !theState.(i).ri.path) failedindices in
+ Safelist.map (fun i -> !theState.(i).ri.path1) failedindices in
debug (fun()-> Util.msg "Rescaning with paths = %s\n"
(String.concat ", " (Safelist.map
(fun p -> "'"^(Path.toString p)^"'")
diff --git a/src/uimacbridgenew.ml b/src/uimacbridgenew.ml
index 3640d5f..7f35f16 100644
--- a/src/uimacbridgenew.ml
+++ b/src/uimacbridgenew.ml
@@ -346,11 +346,11 @@ Callback.register "unisonInit2" unisonInit2;;
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 =
@@ -460,7 +460,6 @@ Callback.register "canDiff" canDiff;;
(* from Uicommon *)
(* precondition: uc = File (Updates(_, ..) on both sides *)
let showDiffs ri printer errprinter id =
- let p = ri.path in
match ri.replicas with
Problem _ ->
errprinter
@@ -471,7 +470,7 @@ let showDiffs ri printer errprinter id =
if filesAreDifferent status1 status2 then
(let (root1,root2) = Globals.roots() in
begin
- try Files.diff root1 p ui1 root2 p ui2 printer id
+ try Files.diff root1 ri.path1 ui1 root2 ri.path2 ui2 printer id
with Util.Transient e -> errprinter e
end)
| Different _ ->
@@ -560,8 +559,8 @@ let do_unisonSynchronize () =
(fun l si ->
l + (match si.whatHappened with Some(Util.Failed(_)) -> 1 | _ -> 0))
0 !theState in
- if count = 0 then "" else
- Printf.sprintf "%d failure%s" count (if count=1 then "" else "s") in
+ if count = 0 then [] else
+ [Printf.sprintf "%d failure%s" count (if count=1 then "" else "s")] in
let partials =
let count =
Array.fold_left
@@ -574,19 +573,19 @@ let do_unisonSynchronize () =
| _ ->
0)
0 !theState in
- if count = 0 then "" else
- Printf.sprintf "%d partially transferred" count in
+ if count = 0 then [] else
+ [Printf.sprintf "%d partially transferred" count] in
let skipped =
let count =
Array.fold_left
(fun l si ->
l + (if problematic si.ri then 1 else 0))
0 !theState in
- if count = 0 then "" else
- Printf.sprintf "%d skipped" count in
+ if count = 0 then [] else
+ [Printf.sprintf "%d skipped" count] in
Trace.status
(Printf.sprintf "Synchronization complete %s"
- (String.concat ", " [failures; partials; skipped]));
+ (String.concat ", " (failures @ partials @ skipped)));
initGlobalProgress Uutil.Filesize.dummy;
end;;
external syncComplete : unit -> unit = "syncComplete";;
@@ -620,7 +619,7 @@ let unisonUpdateForIgnore i =
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
diff --git a/src/uitext.ml b/src/uitext.ml
index f75cdad..3711005 100644
--- a/src/uitext.ml
+++ b/src/uitext.ml
@@ -237,7 +237,7 @@ let interact rilist =
^ System.fspathToPrintString (Prefs.profilePathname n)
^ " and restart " ^ Uutil.myName ^ "\n") end;
let nukeIgnoredRis =
- Safelist.filter (fun ri -> not (Globals.shouldIgnore ri.path)) in
+ Safelist.filter (fun ri -> not (Globals.shouldIgnore ri.path1)) in
loop (nukeIgnoredRis (ri::prev)) (nukeIgnoredRis ril) in
(* This should work on most terminals: *)
let redisplayri() = overwrite (); displayri ri; display "\n" in
@@ -278,17 +278,17 @@ let interact rilist =
(["I"],
("ignore this path permanently"),
(fun () ->
- ignore (Uicommon.ignorePath ri.path) rest
+ ignore (Uicommon.ignorePath ri.path1) rest
"this path"));
(["E"],
("permanently ignore files with this extension"),
(fun () ->
- ignore (Uicommon.ignoreExt ri.path) rest
+ ignore (Uicommon.ignoreExt ri.path1) rest
"files with this extension"));
(["N"],
("permanently ignore paths ending with this name"),
(fun () ->
- ignore (Uicommon.ignoreName ri.path) rest
+ ignore (Uicommon.ignoreName ri.path1) rest
"files with this name"));
(["m"],
("merge the versions"),
@@ -444,7 +444,7 @@ let doTransport reconItemList =
Lwt.try_bind f
(fun () ->
if partiallyProblematic item.ri && not (problematic item.ri) then
- fPartialPaths := item.ri.path :: !fPartialPaths;
+ fPartialPaths := item.ri.path1 :: !fPartialPaths;
Lwt.return ())
(fun e ->
match e with
@@ -455,9 +455,9 @@ let doTransport reconItemList =
in
if rem <> Uutil.Filesize.zero then
showProgress (Uutil.File.ofLine i) rem "done";
- let m = "[" ^ (Path.toString item.ri.path) ^ "]: " ^ s in
+ let m = "[" ^ (Path.toString item.ri.path1) ^ "]: " ^ s in
alwaysDisplay ("Failed " ^ m ^ "\n");
- fFailedPaths := item.ri.path :: !fFailedPaths;
+ fFailedPaths := item.ri.path1 :: !fFailedPaths;
return ()
| _ ->
fail e) in
@@ -571,7 +571,7 @@ let rec interactAndPropagateChanges reconItemList
(fun ri ->
if problematic ri then
alwaysDisplayAndLog
- (" skipped: " ^ (Path.toString ri.path)))
+ (" skipped: " ^ (Path.toString ri.path1)))
newReconItemList;
if partials>0 then
Safelist.iter
diff --git a/src/update.ml b/src/update.ml
index 4ea9d4d..4773b16 100644
--- a/src/update.ml
+++ b/src/update.ml
@@ -1529,7 +1529,7 @@ let findOnRoot =
(fun (fspath, pathList) ->
Lwt.return (findLocal fspath pathList))
-let findUpdatesOnPaths pathList : Common.updateItem list Common.oneperpath =
+let findUpdatesOnPaths pathList =
Lwt_unix.run
(loadArchives true >>= (fun ok ->
begin if ok then Lwt.return () else begin
@@ -1545,7 +1545,8 @@ let findUpdatesOnPaths pathList : Common.updateItem list Common.oneperpath =
let t = Trace.startTimer "Collecting changes" in
Globals.allRootsMapWithWaitingAction (fun r ->
debug (fun() -> Util.msg "findOnRoot %s\n" (root2string r));
- findOnRoot r pathList)
+ findOnRoot r pathList >>= fun updates ->
+ Lwt.return (List.combine pathList updates))
(fun (host, _) ->
begin match host with
Remote _ -> Uutil.showUpdateStatus "";
@@ -1554,11 +1555,18 @@ let findUpdatesOnPaths pathList : Common.updateItem list Common.oneperpath =
end)
>>= (fun updates ->
Trace.showTimer t;
- let result = Safelist.transpose updates in
+ let result =
+ Safelist.map
+ (fun r ->
+ match r with
+ [(p1, u1); (p2, u2)] -> (p1,u1,p2,u2)
+ | _ -> assert false)
+ (Safelist.transpose updates)
+ in
Trace.status "";
- Lwt.return (ONEPERPATH(result))))))
+ Lwt.return result))))
-let findUpdates () : Common.updateItem list Common.oneperpath =
+let findUpdates () =
(* TODO: We should filter the paths to remove duplicates (including prefixes)
and ignored paths *)
findUpdatesOnPaths (Prefs.read Globals.paths)
@@ -1742,8 +1750,8 @@ let markEqual equals =
Lwt_unix.run
(Globals.allRootsIter2
markEqualOnRoot
- [Tree.map (fun n -> n) (fun (uc1,uc2) -> uc1) equals;
- Tree.map (fun n -> n) (fun (uc1,uc2) -> uc2) equals])
+ [Tree.map (fun (nm1, nm2) -> nm1) (fun (uc1,uc2) -> uc1) equals;
+ Tree.map (fun (nm1, nm2) -> nm2) (fun (uc1,uc2) -> uc2) equals])
end
let replaceArchiveLocal fspath path newArch =
diff --git a/src/update.mli b/src/update.mli
index 99a32bc..51134df 100644
--- a/src/update.mli
+++ b/src/update.mli
@@ -18,16 +18,13 @@ val storeRootsName : unit -> unit
(* Retrieve the actual names of the roots *)
val getRootsName : unit -> string
-val findOnRoot :
- Common.root -> Path.t list -> Common.updateItem list Lwt.t
-
(* Structures describing dirty files/dirs (1 per path given in the -path preference) *)
val findUpdates :
- unit -> Common.updateItem list Common.oneperpath
+ unit -> (Path.t * Common.updateItem * Path.t * Common.updateItem) list
(* Take a tree of equal update contents and update the archive accordingly. *)
val markEqual :
- (Name.t, Common.updateContent * Common.updateContent) Tree.t -> unit
+ (Name.t * Name.t, Common.updateContent * Common.updateContent) Tree.t -> unit
(* Get and update a part of an archive (the archive remains unchanged) *)
val updateArchive : Fspath.t -> Path.local -> Common.updateItem -> archive