diff options
author | Jérôme Vouillon <vouillon@pps.jussieu.fr> | 2009-07-10 19:51:15 +0000 |
---|---|---|
committer | Jérôme Vouillon <vouillon@pps.jussieu.fr> | 2009-07-10 19:51:15 +0000 |
commit | 005a53075b998dba27eeff74a1fc8f9d73558fb8 (patch) | |
tree | d81d2687b5f96bd57b9b86e5ebd50ed172794a33 | |
parent | 59e44114fd936c3f53f1d39c6cf442f5921bc243 (diff) | |
download | unison-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/RECENTNEWS | 13 | ||||
-rw-r--r-- | src/common.ml | 4 | ||||
-rw-r--r-- | src/common.mli | 4 | ||||
-rw-r--r-- | src/files.ml | 34 | ||||
-rw-r--r-- | src/files.mli | 5 | ||||
-rw-r--r-- | src/mkProjectInfo.ml | 1 | ||||
-rw-r--r-- | src/recon.ml | 83 | ||||
-rw-r--r-- | src/recon.mli | 2 | ||||
-rw-r--r-- | src/sortri.ml | 8 | ||||
-rw-r--r-- | src/transport.ml | 48 | ||||
-rw-r--r-- | src/uicommon.ml | 7 | ||||
-rw-r--r-- | src/uigtk2.ml | 30 | ||||
-rw-r--r-- | src/uimacbridgenew.ml | 25 | ||||
-rw-r--r-- | src/uitext.ml | 16 | ||||
-rw-r--r-- | src/update.ml | 22 | ||||
-rw-r--r-- | src/update.mli | 7 |
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 |