summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-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
generated by cgit v1.1 at 2025-05-18 08:41:25 +0000