summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/RECENTNEWS12
-rw-r--r--src/common.ml62
-rw-r--r--src/common.mli27
-rw-r--r--src/copy.ml10
-rw-r--r--src/mkProjectInfo.ml1
-rw-r--r--src/recon.ml152
-rw-r--r--src/recon.mli9
-rw-r--r--src/sortri.ml7
-rw-r--r--src/transport.ml16
-rw-r--r--src/uicommon.ml66
-rw-r--r--src/uicommon.mli6
-rw-r--r--src/uigtk2.ml252
-rw-r--r--src/uimacbridge.ml24
-rw-r--r--src/uimacbridgenew.ml35
-rw-r--r--src/uitext.ml57
-rw-r--r--src/update.ml4
16 files changed, 435 insertions, 305 deletions
diff --git a/src/RECENTNEWS b/src/RECENTNEWS
index cb2f090..4be808d 100644
--- a/src/RECENTNEWS
+++ b/src/RECENTNEWS
@@ -1,5 +1,17 @@
CHANGES FROM VERSION 2.36.-27
+* Allow partial transfer of a directory when there was an error deep
+ inside this directory during update detection. At the moment, this
+ is only activated with the text and GTK UIs, which have been
+ modified so that they show that the transfer is going to be partial
+ and so that they can display all errors.
+* Changed types Common.replicaContent and Common.replicas to use
+ records rather than tuples, as this is more readable and easier to
+ extend.
+
+-------------------------------
+CHANGES FROM VERSION 2.36.-27
+
* Bumped version number: incompatible protocol changes
* Partial transfer of directories. If an error occurs while
diff --git a/src/common.ml b/src/common.ml
index b1286e3..e069293 100644
--- a/src/common.ml
+++ b/src/common.ml
@@ -109,7 +109,11 @@ type status =
| `Created
| `Unchanged ]
-type replicaContent = Fileinfo.typ * status * Props.t * updateItem
+type replicaContent =
+ { typ : Fileinfo.typ;
+ status : status;
+ desc : Props.t;
+ ui : updateItem }
type direction =
Conflict
@@ -123,13 +127,17 @@ let direction2string = function
| Replica1ToReplica2 -> "replica1 to replica2"
| Replica2ToReplica1 -> "replica2 to replica1"
+type difference =
+ { rc1 : replicaContent;
+ rc2 : replicaContent;
+ errors1 : string list;
+ errors2 : string list;
+ mutable direction : direction;
+ default_direction : direction }
+
type replicas =
- Problem of string (* There was a problem during update detection *)
- | Different (* Replicas differ *)
- of replicaContent (* - content of first replica *)
- * replicaContent (* - content of second replica *)
- * direction ref (* - action to take *)
- * direction (* - default action to take *)
+ Problem of string (* There was a problem during update detection *)
+ | Different of difference (* Replicas differ *)
type reconItem =
{path : Path.t;
@@ -144,8 +152,8 @@ let uiLength = function
Updates(uc,_) -> ucLength uc
| _ -> Uutil.Filesize.zero
-let riAction (_, s, _, _) (_, s', _, _) =
- match s, s' with
+let riAction rc rc' =
+ match rc.status, rc'.status with
`Deleted, _ ->
`Delete
| (`Unchanged | `PropsChanged), (`Unchanged | `PropsChanged) ->
@@ -153,16 +161,16 @@ let riAction (_, s, _, _) (_, s', _, _) =
| _ ->
`Copy
-let rcLength ((_, _, p, _) as rc) rc' =
+let rcLength rc rc' =
if riAction rc rc' = `SetProps then
Uutil.Filesize.zero
else
- Props.length p
+ Props.length rc.desc
let riLength ri =
match ri.replicas with
- Different(rc1, rc2, dir, _) ->
- begin match !dir with
+ Different {rc1 = rc1; rc2 = rc2; direction = dir} ->
+ begin match dir with
Replica1ToReplica2 -> rcLength rc1 rc2
| Replica2ToReplica1 -> rcLength rc2 rc1
| Conflict -> Uutil.Filesize.zero
@@ -193,26 +201,32 @@ let fileInfos ui1 ui2 =
let problematic ri =
match ri.replicas with
- Problem _ -> true
- | Different (_,_,d,_) -> (!d = Conflict)
+ Problem _ -> true
+ | Different diff -> diff.direction = Conflict
+
+let partiallyProblematic ri =
+ match ri.replicas with
+ Problem _ ->
+ true
+ | Different diff ->
+ diff.direction = Conflict || diff.errors1 <> [] || diff.errors2 <> []
let isDeletion ri =
match ri.replicas with
- Different(rc1, rc2, rDir, _) ->
- (match (!rDir, rc1, rc2) with
- (Replica1ToReplica2, (`ABSENT, _, _, _), _) -> true
- | (Replica2ToReplica1, _, (`ABSENT, _, _, _)) -> true
+ Different {rc1 = rc1; rc2 = rc2; direction = rDir} ->
+ (match rDir, rc1.typ, rc2.typ with
+ Replica1ToReplica2, `ABSENT, _ -> true
+ | Replica2ToReplica1, _, `ABSENT -> true
| _ -> false)
| _ -> false
-let rcType (fi, _, _, _) =
- Fileinfo.type2string fi
+let rcType rc = Fileinfo.type2string rc.typ
let riFileType ri =
match ri.replicas with
- Different(rc1, rc2, dir, _) ->
- begin match !dir with
+ Different {rc1 = rc1; rc2 = rc2; default_direction = dir} ->
+ begin match dir with
Replica2ToReplica1 -> rcType rc2
- | _ -> rcType rc1
+ | _ -> rcType rc1
end
| _ -> "nonexistent"
diff --git a/src/common.mli b/src/common.mli
index b358d09..b00f7c9 100644
--- a/src/common.mli
+++ b/src/common.mli
@@ -87,7 +87,11 @@ type status =
| `Unchanged ]
(* Variable name prefix: "rc" *)
-type replicaContent = Fileinfo.typ * status * Props.t * updateItem
+type replicaContent =
+ { typ : Fileinfo.typ;
+ status : status;
+ desc : Props.t;
+ ui : updateItem }
type direction =
Conflict
@@ -97,15 +101,19 @@ type direction =
val direction2string : direction -> string
+type difference =
+ { rc1 : replicaContent; (* - content of first replica *)
+ rc2 : replicaContent; (* - content of second replica *)
+ errors1 : string list; (* - deep errors in first replica *)
+ errors2 : string list; (* - deep errors in second replica *)
+ mutable direction : direction; (* - action to take (it's mutable so that
+ the user interface can change it) *)
+ default_direction : direction } (* - default action to take *)
+
(* Variable name prefix: "rplc" *)
type replicas =
- Problem of string (* There was a problem during update detection *)
- | Different (* Replicas differ *)
- of replicaContent (* - content of first replica *)
- * replicaContent (* - content of second replica *)
- * direction ref (* - action to take (it's a ref so that the
- user interface can change it) *)
- * direction (* - default action to take *)
+ Problem of string (* There was a problem during update detection *)
+ | Different of difference (* Replicas differ *)
(* Variable name prefix: "ri" *)
type reconItem =
@@ -124,4 +132,7 @@ val fileInfos :
(* True if the ri's type is Problem or if it is Different and the direction
is Conflict *)
val problematic : reconItem -> bool
+(* True if the ri is problematic or if it has some deep errors in a
+ directory *)
+val partiallyProblematic : reconItem -> bool
val isDeletion : reconItem -> bool
diff --git a/src/copy.ml b/src/copy.ml
index ddd9c30..6063652 100644
--- a/src/copy.ml
+++ b/src/copy.ml
@@ -661,11 +661,13 @@ let transferFileLocal connFrom
(* File is already fully transferred (from some interrupted
previous transfer). *)
(* Make sure permissions are right. *)
- Trace.log (Printf.sprintf
- "%s/%s has already been transferred\n"
- (Fspath.toDebugString fspathTo) (Path.toString pathTo));
+ let msg =
+ Printf.sprintf
+ "%s/%s has already been transferred\n"
+ (Fspath.toDebugString fspathTo) (Path.toString pathTo)
+ in
setFileinfo fspathTo pathTo realPathTo update desc;
- Lwt.return (`DONE (Success info, None))
+ Lwt.return (`DONE (Success info, Some msg))
end else
match
tryCopyMovedFile fspathTo pathTo realPathTo update desc fp ress id
diff --git a/src/mkProjectInfo.ml b/src/mkProjectInfo.ml
index 8e97031..1c82709 100644
--- a/src/mkProjectInfo.ml
+++ b/src/mkProjectInfo.ml
@@ -166,3 +166,4 @@ Printf.printf "NAME=%s\n" projectName;;
+
diff --git a/src/recon.ml b/src/recon.ml
index 6dcfbbf..2c68424 100644
--- a/src/recon.ml
+++ b/src/recon.ml
@@ -25,39 +25,37 @@ let debug = Trace.debug "recon"
let setDirection ri dir force =
match ri.replicas with
- Different(rc1,rc2,d,default) when force=`Force || default=Conflict ->
+ Different
+ ({rc1 = rc1; rc2 = rc2; direction = d; default_direction = default } as diff)
+ when force=`Force || default=Conflict ->
if dir=`Replica1ToReplica2 then
- d := Replica1ToReplica2
+ diff.direction <- Replica1ToReplica2
else if dir=`Replica2ToReplica1 then
- d := Replica2ToReplica1
- else if dir=`Merge then
- if Globals.shouldMerge ri.path then d := Merge else ()
- else (* dir = `Older or dir = `Newer *)
- let (_,s1,p1,_) = rc1 in
- let (_,s2,p2,_) = rc2 in
- if s1<>`Deleted && s2<>`Deleted then begin
- let comp = (Props.time p1) -. (Props.time p2) in
+ diff.direction <- Replica2ToReplica1
+ else if dir=`Merge then begin
+ if Globals.shouldMerge ri.path 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
let comp = if dir=`Newer then -. comp else comp in
if comp = 0.0 then
()
else if comp<0.0 then
- d := Replica1ToReplica2
+ diff.direction <- Replica1ToReplica2
else
- d := Replica2ToReplica1
- end else if s1=`Deleted && dir=`Newer then begin
- d := Replica2ToReplica1
- end else if s2=`Deleted && dir=`Newer then begin
- d := Replica1ToReplica2
+ diff.direction <- Replica2ToReplica1
+ end else if rc1.status=`Deleted && dir=`Newer then begin
+ diff.direction <- Replica2ToReplica1
+ end else if rc2.status=`Deleted && dir=`Newer then begin
+ diff.direction <- Replica1ToReplica2
end
| _ ->
()
let revertToDefaultDirection ri =
match ri.replicas with
- Different(_,_,d,default) ->
- d := default
- | _ ->
- ()
+ Different diff -> diff.direction <- diff.default_direction
+ | _ -> ()
(* Find out which direction we need to propagate changes if we want to *)
(* consider the given root to be the "truth" *)
@@ -213,16 +211,34 @@ let rec checkForError ui =
| Absent | File _ | Symlink _ ->
()
+let rec collectErrors ui rem =
+ match ui with
+ NoUpdates ->
+ rem
+ | Error err ->
+ err :: rem
+ | Updates (uc, _) ->
+ match uc with
+ Dir (_, children, _, _) ->
+ Safelist.fold_right
+ (fun (_, uiSub) rem -> collectErrors uiSub rem) children rem
+ | Absent | File _ | Symlink _ ->
+ rem
+
(* lifting errors in individual updates to replica problems *)
-let propagateErrors (rplc: Common.replicas): Common.replicas =
+let propagateErrors allowPartial (rplc: Common.replicas): Common.replicas =
match rplc with
Problem _ ->
rplc
- | Different ((_, _, _, ui1), (_, _, _, ui2), _, _) ->
+ | Different diff when allowPartial ->
+ Different { diff with
+ errors1 = collectErrors diff.rc1.ui [];
+ errors2 = collectErrors diff.rc2.ui [] }
+ | Different diff ->
try
- checkForError ui1;
+ checkForError diff.rc1.ui;
try
- checkForError ui2;
+ checkForError diff.rc2.ui;
rplc
with UpdateError err ->
Problem ("[root 2]: " ^ err)
@@ -235,29 +251,29 @@ let update2replicaContent (conflict: bool) ui ucNew oldType:
Common.replicaContent =
match ucNew with
Absent ->
- (`ABSENT, `Deleted, Props.dummy, ui)
+ {typ = `ABSENT; status = `Deleted; desc = Props.dummy; ui = ui}
| File (desc, ContentsSame) ->
- (`FILE, `PropsChanged, desc, ui)
+ {typ = `FILE; status = `PropsChanged; desc = desc; ui = ui}
| File (desc, _) when oldType <> `FILE ->
- (`FILE, `Created, desc, ui)
+ {typ = `FILE; status = `Created; desc = desc; ui = ui}
| File (desc, ContentsUpdated _) ->
- (`FILE, `Modified, desc, ui)
+ {typ = `FILE; status = `Modified; desc = desc; ui = ui}
| Symlink l when oldType <> `SYMLINK ->
- (`SYMLINK, `Created, Props.dummy, ui)
+ {typ = `SYMLINK; status = `Created; desc = Props.dummy; ui = ui}
| Symlink l ->
- (`SYMLINK, `Modified, Props.dummy, ui)
+ {typ = `SYMLINK; status = `Modified; desc = Props.dummy; ui = ui}
| Dir (desc, _, _, _) when oldType <> `DIRECTORY ->
- (`DIRECTORY, `Created, desc, ui)
+ {typ = `DIRECTORY; status = `Created; desc = desc; ui = ui}
| Dir (desc, _, PropsUpdated, _) ->
- (`DIRECTORY, `PropsChanged, desc, ui)
+ {typ = `DIRECTORY; status = `PropsChanged; desc = desc; ui = ui}
| Dir (desc, _, PropsSame, _) when conflict ->
(* Special case: the directory contents has been modified and the *)
(* directory is in conflict. (We don't want to display a conflict *)
(* between an unchanged directory and a file, for instance: this would *)
(* be rather puzzling to the user) *)
- (`DIRECTORY, `Modified, desc, ui)
+ {typ = `DIRECTORY; status = `Modified; desc = desc; ui = ui}
| Dir (desc, _, PropsSame, _) ->
- (`DIRECTORY, `Unchanged, desc, ui)
+ {typ = `DIRECTORY; status = `Unchanged; desc =desc; ui = ui}
let oldType (prev: Common.prevState): Fileinfo.typ =
match prev with
@@ -277,24 +293,28 @@ let describeUpdate ui
Updates (ucNewStatus, prev) ->
let typ = oldType prev in
(update2replicaContent false ui ucNewStatus typ,
- (typ, `Unchanged, oldDesc prev, NoUpdates))
+ {typ = typ; status = `Unchanged; desc = oldDesc prev; ui = NoUpdates})
| _ -> assert false
(* Computes the reconItems when only one side has been updated. (We split *)
(* this out into a separate function to avoid duplicating all the symmetric *)
(* cases.) *)
-let rec reconcileNoConflict ui whatIsUpdated
+let rec reconcileNoConflict allowPartial ui whatIsUpdated
(result: (Name.t, Common.replicas) Tree.u)
: (Name.t, Common.replicas) Tree.u =
let different() =
let rcUpdated, rcNotUpdated = describeUpdate ui in
match whatIsUpdated with
Rep2Updated ->
- Different(rcNotUpdated, rcUpdated,
- ref Replica2ToReplica1, Replica2ToReplica1)
+ Different {rc1 = rcNotUpdated; rc2 = rcUpdated;
+ direction = Replica2ToReplica1;
+ default_direction = Replica2ToReplica1;
+ errors1 = []; errors2 = []}
| Rep1Updated ->
- Different(rcUpdated, rcNotUpdated,
- ref Replica1ToReplica2, Replica1ToReplica2) in
+ Different {rc1 = rcUpdated; rc2 = rcNotUpdated;
+ direction = Replica1ToReplica2;
+ default_direction = Replica1ToReplica2;
+ errors1 = []; errors2 = []} in
match ui with
| NoUpdates -> result
| Error err ->
@@ -307,11 +327,11 @@ let rec reconcileNoConflict ui whatIsUpdated
Safelist.fold_left
(fun result (theName, uiChild) ->
Tree.leave
- (reconcileNoConflict
+ (reconcileNoConflict allowPartial
uiChild whatIsUpdated (Tree.enter result theName)))
r children
| Updates _ ->
- Tree.add result (propagateErrors (different ()))
+ Tree.add result (propagateErrors allowPartial (different ()))
(* [combineChildrn children1 children2] combines two name-sorted lists of *)
(* type [(Name.t * Common.updateItem) list] to a single list of type *)
@@ -361,32 +381,32 @@ let add_equal (counter, archiveUpdated) equal v =
(* Tree.u *)
(* unequals: (Name.t, Common.replicas) Tree.u *)
(* -- *)
-let rec reconcile path ui1 ui2 counter equals unequals =
+let rec reconcile allowPartial path ui1 ui2 counter equals unequals =
let different uc1 uc2 oldType equals unequals =
(equals,
Tree.add unequals
- (propagateErrors
- (Different(update2replicaContent true ui1 uc1 oldType,
- update2replicaContent true ui2 uc2 oldType,
- ref Conflict,
- Conflict)))) in
+ (propagateErrors allowPartial
+ (Different {rc1 = update2replicaContent true ui1 uc1 oldType;
+ rc2 = update2replicaContent true ui2 uc2 oldType;
+ direction = Conflict; default_direction = Conflict;
+ errors1 = []; errors2 = []}))) in
let toBeMerged uc1 uc2 oldType equals unequals =
(equals,
Tree.add unequals
- (propagateErrors
- (Different(update2replicaContent true ui1 uc1 oldType,
- update2replicaContent true ui2 uc2 oldType,
- ref Merge,
- Merge)))) in
+ (propagateErrors allowPartial
+ (Different {rc1 = update2replicaContent true ui1 uc1 oldType;
+ rc2 = update2replicaContent true ui2 uc2 oldType;
+ direction = Merge; default_direction = Merge;
+ errors1 = []; errors2 = []}))) in
match (ui1, ui2) with
(Error s, _) ->
(equals, Tree.add unequals (Problem s))
| (_, Error s) ->
(equals, Tree.add unequals (Problem s))
| (NoUpdates, _) ->
- (equals, reconcileNoConflict ui2 Rep2Updated unequals)
+ (equals, reconcileNoConflict allowPartial ui2 Rep2Updated unequals)
| (_, NoUpdates) ->
- (equals, reconcileNoConflict ui1 Rep1Updated unequals)
+ (equals, reconcileNoConflict allowPartial ui1 Rep1Updated unequals)
| (Updates (Absent, _), Updates (Absent, _)) ->
(add_equal counter equals (Absent, Absent), unequals)
| (Updates (Dir (desc1, children1, propsChanged1, _) as uc1, prevState1),
@@ -407,15 +427,16 @@ let rec reconcile path ui1 ui2 counter equals unequals =
(equals,
Tree.add unequals
(Different
- (update2replicaContent false ui1 uc1 `DIRECTORY,
- update2replicaContent false ui2 uc2 `DIRECTORY,
- ref action, action)))
+ {rc1 = update2replicaContent false ui1 uc1 `DIRECTORY;
+ rc2 = update2replicaContent false ui2 uc2 `DIRECTORY;
+ direction = action; default_direction = action;
+ errors1 = []; errors2 = []}))
in
(* Apply reconcile on children. *)
Safelist.fold_left
(fun (equals, unequals) (name,ui1,ui2) ->
let (eq, uneq) =
- reconcile (Path.child path name) ui1 ui2 counter
+ reconcile allowPartial (Path.child path name) ui1 ui2 counter
(Tree.enter equals name) (Tree.enter unequals name)
in
(Tree.leave eq, Tree.leave uneq))
@@ -481,8 +502,9 @@ 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 (pathUpdatesList: (Path.t * Common.updateItem list) list)
- : Common.reconItem list * bool * Path.t list =
+let reconcileList allowPartial
+ (pathUpdatesList: (Path.t * Common.updateItem list) list)
+ : Common.reconItem list * bool * Path.t list =
let counter = ref 0 in
let archiveUpdated = ref false in
let (equals, unequals, dangerous) =
@@ -491,7 +513,7 @@ let reconcileList (pathUpdatesList: (Path.t * Common.updateItem list) list)
match updatesList with
[ui1; ui2] ->
let (equals, unequals) =
- reconcile path ui1 ui2 (counter, archiveUpdated)
+ reconcile allowPartial path ui1 ui2 (counter, archiveUpdated)
(enterPath path equals) (enterPath path unequals)
in
(leavePath path equals, leavePath path unequals,
@@ -516,12 +538,10 @@ let reconcileList (pathUpdatesList: (Path.t * Common.updateItem list) list)
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 (ONEPERPATH(updatesListList)) =
+let reconcileAll ?(allowPartial = false) (ONEPERPATH(updatesListList)) =
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 pathUpdatesList
-
-let reconcileTwo p ui ui' = reconcileList [(p, [ui; ui'])]
+ reconcileList allowPartial pathUpdatesList
diff --git a/src/recon.mli b/src/recon.mli
index 9640231..42fcfad 100644
--- a/src/recon.mli
+++ b/src/recon.mli
@@ -2,16 +2,13 @@
(* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *)
val reconcileAll :
- Common.updateItem list Common.oneperpath
+ ?allowPartial:bool (* whether we allow partial synchronization
+ of directories (default to false) *)
+ -> Common.updateItem list Common.oneperpath
(* one updateItem per replica, per path *)
-> Common.reconItem list (* List of updates that need propagated *)
* bool (* Any file updated equally on all roots*)
* Path.t list (* Paths which have been emptied on one side*)
-(* --------------- *)
-
-val reconcileTwo : Path.t -> Common.updateItem -> Common.updateItem ->
- Common.reconItem list * bool * Path.t list
-
(* Use the current values of the '-prefer <ROOT>' and '-force <ROOT>' *)
(* preferences to override the reconciler's choices *)
diff --git a/src/sortri.ml b/src/sortri.ml
index adbd172..00a7be2 100644
--- a/src/sortri.ml
+++ b/src/sortri.ml
@@ -104,14 +104,14 @@ let shouldSortFirst ri =
let shouldSortLast ri =
Pred.test sortlast (Path.toString ri.path)
-let newItem ri =
+let newItem ri =
let newItem1 ri =
match ri.replicas with
- Different((_, `Created, _, _), _, _, _) -> true
+ Different diff -> diff.rc1.status = `Created
| _ -> false in
let newItem2 ri =
match ri.replicas with
- Different(_, (_, `Created, _, _), _, _) -> true
+ Different diff -> diff.rc2.status = `Created
| _ -> false
in newItem1 ri || newItem2 ri
@@ -130,6 +130,7 @@ let compareReconItems () =
let cmp =
combineCmp [
pred problematic;
+ pred partiallyProblematic;
pred shouldSortFirst;
invertCmp (pred shouldSortLast);
if newfirst then pred newItem else 0;
diff --git a/src/transport.ml b/src/transport.ml
index 970f163..4f33410 100644
--- a/src/transport.ml
+++ b/src/transport.ml
@@ -88,7 +88,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id =
Trace.statusDetail (Path.toString path);
Remote.Thread.unwindProtect (fun () ->
match fromContents, toContents with
- (`ABSENT, _, _, _), (_, _, _, uiTo) ->
+ {typ = `ABSENT}, {ui = uiTo} ->
logLwtNumbered
("Deleting " ^ Path.toString path ^
"\n from "^ root2string toRoot)
@@ -97,8 +97,8 @@ let doAction (fromRoot,toRoot) path fromContents toContents id =
(* 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.) *)
- | (_, (`Unchanged | `PropsChanged), fromProps, uiFrom),
- (_, (`Unchanged | `PropsChanged), toProps, uiTo) ->
+ | {status= `Unchanged | `PropsChanged; desc= fromProps; ui= uiFrom},
+ {status= `Unchanged | `PropsChanged; desc= toProps; ui = uiTo} ->
logLwtNumbered
("Copying properties for " ^ Path.toString path
^ "\n from " ^ root2string fromRoot ^ "\n to " ^
@@ -107,7 +107,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id =
(fun () ->
Files.setProp
fromRoot path toRoot path fromProps toProps uiFrom uiTo)
- | (`FILE, _, _, uiFrom), (`FILE, _, _, uiTo) ->
+ | {typ = `FILE; ui = uiFrom}, {typ = `FILE; ui = uiTo} ->
logLwtNumbered
("Updating file " ^ Path.toString path ^ "\n from " ^
root2string fromRoot ^ "\n to " ^
@@ -116,7 +116,7 @@ let doAction (fromRoot,toRoot) path fromContents toContents id =
(fun () ->
Files.copy (`Update (fileSize uiFrom uiTo))
fromRoot path uiFrom toRoot path uiTo id)
- | (_, _, _, uiFrom), (_, _, _, uiTo) ->
+ | {ui = uiFrom}, {ui = uiTo} ->
logLwtNumbered
("Copying " ^ Path.toString path ^ "\n from " ^
root2string fromRoot ^ "\n to " ^
@@ -137,8 +137,8 @@ let propagate root1 root2 reconItem id showMergeFn =
Trace.log (Printf.sprintf "[ERROR] Skipping %s\n %s\n"
(Path.toString path) p);
return ()
- | Different(rc1,rc2,dir,_) ->
- match !dir with
+ | Different {rc1 = rc1; rc2 = rc2; direction = dir} ->
+ match dir with
Conflict ->
Trace.log (Printf.sprintf "[CONFLICT] Skipping %s\n"
(Path.toString path));
@@ -149,7 +149,7 @@ let propagate root1 root2 reconItem id showMergeFn =
doAction (root2, root1) path rc2 rc1 id
| Merge ->
begin match (rc1,rc2) with
- (`FILE, _, _, ui1), (`FILE, _, _, ui2) ->
+ {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")
diff --git a/src/uicommon.ml b/src/uicommon.ml
index 43f97d0..f0952dc 100644
--- a/src/uicommon.ml
+++ b/src/uicommon.ml
@@ -187,17 +187,16 @@ let prevProps newprops ui =
(* || Props.similar newprops oldprops *)
" (was: "^(Props.toString oldprops)^")"
-let replicaContent2string rc sep =
- let (typ, status, desc, ui) = rc in
- let d s = s ^ sep ^ Props.toString desc ^ prevProps desc ui in
- match typ, status with
+let replicaContent2string rc sep =
+ let d s = s ^ sep ^ Props.toString rc.desc ^ prevProps rc.desc rc.ui in
+ match rc.typ, rc.status with
`ABSENT, `Unchanged ->
"absent"
| _, `Unchanged ->
"unchanged "
- ^(Util.truncateString (Fileinfo.type2string typ) 7)
+ ^(Util.truncateString (Fileinfo.type2string rc.typ) 7)
^ sep
- ^(Props.toString desc)
+ ^(Props.toString rc.desc)
| `ABSENT, `Deleted -> "deleted"
| `FILE, `Created ->
d (choose "new file " "file ")
@@ -223,8 +222,7 @@ let replicaContent2string rc sep =
assert false
let replicaContent2shortString rc =
- let (typ, status, _, _) = rc in
- match typ, status with
+ match rc.typ, rc.status with
_, `Unchanged -> " "
| `ABSENT, `Deleted -> "deleted "
| `FILE, `Created -> choose "new file" "file "
@@ -255,7 +253,7 @@ let details2string theRi sep =
match theRi.replicas with
Problem s ->
Printf.sprintf "Error: %s\n" s
- | Different(rc1, rc2, _, _) ->
+ | Different {rc1 = rc1; rc2 = rc2} ->
let root1str, root2str =
roots2niceStrings 12 (Globals.roots()) in
Printf.sprintf "%s : %s\n%s : %s"
@@ -286,25 +284,39 @@ let roots2string () =
let replica1, replica2 = roots2niceStrings 12 (Globals.roots()) in
(Printf.sprintf "%s %s " replica1 replica2)
-let direction2niceString = function
- Conflict -> "<-?->"
- | Replica1ToReplica2 -> "---->"
- | Replica2ToReplica1 -> "<----"
- | Merge -> "<-M->"
+type action = AError | ASkip of bool | ALtoR of bool | ARtoL of bool | AMerge
+
+let direction2action partial dir =
+ match dir with
+ Conflict -> ASkip partial
+ | Replica1ToReplica2 -> ALtoR partial
+ | Replica2ToReplica1 -> ARtoL partial
+ | Merge -> AMerge
+
+let action2niceString action =
+ match action with
+ AError -> "error"
+ | ASkip _ -> "<-?->"
+ | ALtoR false -> "---->"
+ | ALtoR true -> "--?->"
+ | ARtoL false -> "<----"
+ | ARtoL true -> "<-?--"
+ | AMerge -> "<-M->"
+
+let reconItem2stringList oldPath theRI =
+ match theRI.replicas with
+ Problem s ->
+ (" ", AError, " ", displayPath oldPath theRI.path)
+ | Different diff ->
+ let partial = diff.errors1 <> [] || diff.errors2 <> [] in
+ (replicaContent2shortString diff.rc1,
+ direction2action partial diff.direction,
+ replicaContent2shortString diff.rc2,
+ displayPath oldPath theRI.path)
let reconItem2string oldPath theRI status =
- let theLine =
- match theRI.replicas with
- Problem s ->
- " error " ^ status
- | Different(rc1, rc2, dir, _) ->
- let signs =
- Printf.sprintf "%s %s %s"
- (replicaContent2shortString rc1)
- (direction2niceString (!dir))
- (replicaContent2shortString rc2) in
- Printf.sprintf "%s %s" signs status in
- Printf.sprintf "%s %s" theLine (displayPath oldPath theRI.path)
+ let (r1, action, r2, path) = reconItem2stringList oldPath theRI in
+ Format.sprintf "%s %s %s %s %s" r1 (action2niceString action) r2 status path
let exn2string = function
Sys.Break -> "Terminated!"
@@ -319,7 +331,7 @@ let showDiffs ri printer errprinter id =
Problem _ ->
errprinter
"Can't diff files: there was a problem during update detection"
- | Different((`FILE, _, _, ui1), (`FILE, _, _, ui2), _, _) ->
+ | 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
diff --git a/src/uicommon.mli b/src/uicommon.mli
index 9e98b34..af2ccc1 100644
--- a/src/uicommon.mli
+++ b/src/uicommon.mli
@@ -59,6 +59,12 @@ val roots2string : unit -> string
initial components that are the same as the previous path *)
val reconItem2string : Path.t -> Common.reconItem -> string -> string
+type action = AError | ASkip of bool | ALtoR of bool | ARtoL of bool | AMerge
+
+(* Same as previous function, but returns a tuple of strings *)
+val reconItem2stringList :
+ Path.t -> Common.reconItem -> string * action * string * string
+
(* Format an exception for display *)
val exn2string : exn -> string
diff --git a/src/uigtk2.ml b/src/uigtk2.ml
index cc2b35f..3dd9c45 100644
--- a/src/uigtk2.ml
+++ b/src/uigtk2.ml
@@ -795,9 +795,7 @@ let getPassword rootName msg =
(Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in
let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in
- (* FIX: DIALOG_AUTHENTICATION is way better but is not available
- in the current release of LablGTK2... *)
- ignore (GMisc.image ~stock:(*`DIALOG_AUTHENTICATION*)`DIALOG_QUESTION ~icon_size:`DIALOG
+ ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG
~yalign:0. ~packing:h1#pack ());
let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in
ignore(GMisc.label ~markup:(header ^ "\n\n" ^
@@ -1198,6 +1196,8 @@ let displayWaitMessage () =
(* ------ *)
+type status = NoStatus | Done | Failed
+
let rec createToplevelWindow () =
let toplevelWindow = getMyWindow() in
(* There is already a default icon under Windows, and transparent
@@ -1218,8 +1218,16 @@ let rec createToplevelWindow () =
let grDiff = ref [] in
let grGo = ref [] in
let grRescan = ref [] in
+ let grDetail = ref [] in
let grAdd gr w = gr := w#misc::!gr in
let grSet gr st = Safelist.iter (fun x -> x#set_sensitive st) !gr in
+ let grDisactivateAll () =
+ grSet grAction false;
+ grSet grDiff false;
+ grSet grGo false;
+ grSet grRescan false;
+ grSet grDetail false
+ in
(*********************************************************************
Create the menu bar
@@ -1349,64 +1357,82 @@ let rec createToplevelWindow () =
Create the details window
*********************************************************************)
- let (showDetailsButton, detailsWindow) =
+ let showDetCommand () =
+ let details =
+ match !current with
+ None ->
+ None
+ | Some row ->
+ 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)
+ | _ ->
+ match !theState.(row).ri.replicas with
+ Problem _ ->
+ None
+ | Different diff ->
+ let prefix s l =
+ Safelist.map (fun err -> Format.sprintf "%s%s\n" s err) l
+ in
+ let errors =
+ Safelist.append
+ (prefix "[root 1]: " diff.errors1)
+ (prefix "[root 2]: " diff.errors2)
+ in
+ let path = Path.toString !theState.(row).ri.path in
+ Some ("Errors for file " ^ transcodeFilename path,
+ String.concat "\n" errors)
+ in
+ match details with
+ None -> ((* Should not happen *))
+ | Some (title, details) -> messageBox ~title (transcode details)
+ in
+
+ let detailsWindow =
let sw =
GBin.frame ~packing:(toplevelVBox#pack ~expand:false)
~shadow_type:`IN (*~hpolicy:`AUTOMATIC ~vpolicy:`NEVER*) () in
- let hb =GPack.hbox ~packing:sw#add () in
- (GButton.button ~label:"View details..."
- ~show:false ~packing:(hb#pack ~expand:false) (),
- GText.view ~editable:false ~wrap_mode:`NONE ~packing:hb#add ())
-
+ GText.view ~editable:false ~wrap_mode:`NONE ~packing:sw#add ()
in
detailsWindow#misc#modify_font (Lazy.force fontMonospaceMediumPango);
detailsWindow#misc#set_size_chars ~height:3 ~width:112 ();
detailsWindow#misc#set_can_focus false;
- let showDetCommand () =
- let details =
- match !current with
- None -> "[No details available]"
- | Some row ->
- (match !theState.(row).whatHappened with
- Some (Util.Failed _, Some det) -> det
- | _ -> "[No details available]") in
- messageBox ~title:"Merge execution details" details
- in
- ignore (showDetailsButton#connect#clicked ~callback:showDetCommand);
-
+
let updateButtons () =
match !current with
None ->
grSet grAction false;
grSet grDiff false;
- showDetailsButton#misc#hide ()
+ grSet grDetail false
| Some row ->
- let (details, activate1, activate2) =
- match !theState.(row).whatHappened, !theState.(row).ri.replicas with
- | None, Different((`FILE, _, _, _),(`FILE, _, _, _), _, _) ->
- (false, true, true)
- | Some res, Different((`FILE, _, _, _),(`FILE, _, _, _), _, _) ->
- (match res with
- Util.Succeeded, _ -> (false, false, true)
- | Util.Failed s, None -> (false, false, true)
- | Util.Failed s, Some dText -> (true, false, false)
- )
- | Some res, _ ->
- (match res with
- Util.Succeeded, _ -> (false, false, false)
- | Util.Failed s, None -> (false, false, false)
- | Util.Failed s, Some dText -> (true, false, false)
- )
- | None, _ ->
- (false, true, false) in
+ let details =
+ begin match !theState.(row).ri.replicas with
+ Different diff -> diff.errors1 <> [] || diff.errors2 <> []
+ | Problem _ -> false
+ end
+ ||
+ begin match !theState.(row).whatHappened with
+ Some (Util.Failed _, Some dText) -> true
+ | _ -> false
+ end
+ in
+ grSet grDetail details;
if not !busy then begin
- grSet grAction activate1;
- grSet grDiff activate2
+ let activateAction = !theState.(row).whatHappened = None in
+ let activateDiff =
+ activateAction &&
+ match !theState.(row).ri.replicas with
+ Different {rc1 = {typ = `FILE}; rc2 = {typ = `FILE}} ->
+ true
+ | _ ->
+ false
+ in
+ grSet grAction activateAction;
+ grSet grDiff activateDiff
end;
- if details then
- showDetailsButton#misc#show ()
- else
- showDetailsButton#misc#hide ()
in
let makeRowVisible row =
@@ -1498,8 +1524,8 @@ let rec createToplevelWindow () =
let rec loop i =
if i < l then
match !theState.(i).ri.replicas with
- Different (_, _, dir, _)
- when not (Prefs.read Uicommon.auto) || !dir = Conflict ->
+ Different {direction = dir}
+ when not (Prefs.read Uicommon.auto) || dir = Conflict ->
select i
| _ ->
loop (i + 1) in
@@ -1510,27 +1536,24 @@ let rec createToplevelWindow () =
let columnsOf i =
let oldPath = if i = 0 then Path.empty else !theState.(i-1).ri.path in
let status =
- match !theState.(i).whatHappened with
- None -> " "
- | Some conf ->
- match !theState.(i).ri.replicas with
- Different(_,_,{contents=Conflict},_) | Problem _ ->
- " "
- | _ ->
- match conf with
- Util.Succeeded, _ -> "done "
- | Util.Failed _, _ -> "failed" in
- let s = Uicommon.reconItem2string oldPath !theState.(i).ri status in
- (* FIX: This is ugly *)
- (String.sub s 0 8,
- String.sub s 9 5,
- String.sub s 15 8,
- String.sub s 25 6,
- String.sub s 32 (String.length s - 32)) in
+ match !theState.(i).ri.replicas with
+ Different {direction = Conflict} | Problem _ ->
+ NoStatus
+ | _ ->
+ match !theState.(i).whatHappened with
+ None -> NoStatus
+ | Some (Util.Succeeded, _) -> Done
+ | Some (Util.Failed _, _) -> Failed
+ in
+ let (r1, action, r2, path) =
+ Uicommon.reconItem2stringList oldPath !theState.(i).ri in
+ (r1, action, r2, status, path)
+ in
let greenPixel = "00dd00" in
let redPixel = "ff2040" in
let lightbluePixel = "8888FF" in
+ let orangePixel = "ff9303" in
(*
let yellowPixel = "999900" in
let blackPixel = "000000" in
@@ -1540,11 +1563,14 @@ let rec createToplevelWindow () =
let buildPixmaps f c1 =
(buildPixmap (f c1), buildPixmap (f lightbluePixel)) in
+ let doneIcon = buildPixmap Pixmaps.success in
+ let failedIcon = buildPixmap Pixmaps.failure in
let rightArrow = buildPixmaps Pixmaps.copyAB greenPixel in
let leftArrow = buildPixmaps Pixmaps.copyBA greenPixel in
+ let orangeRightArrow = buildPixmaps Pixmaps.copyAB orangePixel in
+ let orangeLeftArrow = buildPixmaps Pixmaps.copyBA orangePixel in
let ignoreAct = buildPixmaps Pixmaps.ignore redPixel in
- let doneIcon = buildPixmap Pixmaps.success in
- let failedIcon = buildPixmap Pixmaps.failure in
+ let failedIcons = (failedIcon, failedIcon) in
let mergeLogo = buildPixmaps Pixmaps.mergeLogo greenPixel in
(*
let rightArrowBlack = buildPixmap (Pixmaps.copyAB blackPixel) in
@@ -1554,23 +1580,29 @@ let rec createToplevelWindow () =
let displayArrow i j action =
let changedFromDefault = match !theState.(j).ri.replicas with
- Different(_,_,{contents=curr},default) -> curr<>default
+ Different diff -> diff.direction <> diff.default_direction
| _ -> false in
let sel pixmaps =
if changedFromDefault then snd pixmaps else fst pixmaps in
- match action with
- "<-?->" -> mainWindow#set_cell ~pixmap:(sel ignoreAct) i 1
- | "<-M->" -> mainWindow#set_cell ~pixmap:(sel mergeLogo) i 1
- | "---->" -> mainWindow#set_cell ~pixmap:(sel rightArrow) i 1
- | "<----" -> mainWindow#set_cell ~pixmap:(sel leftArrow) i 1
- | "error" -> mainWindow#set_cell ~pixmap:failedIcon i 1
- | _ -> assert false in
+ let pixmaps =
+ match action with
+ Uicommon.AError -> failedIcons
+ | Uicommon.ASkip _ -> ignoreAct
+ | Uicommon.ALtoR false -> rightArrow
+ | Uicommon.ALtoR true -> orangeRightArrow
+ | Uicommon.ARtoL false -> leftArrow
+ | Uicommon.ARtoL true -> orangeLeftArrow
+ | Uicommon.AMerge -> mergeLogo
+ in
+ mainWindow#set_cell ~pixmap:(sel pixmaps) i 1
+ in
+
let displayStatusIcon i status =
match status with
- | "failed" -> mainWindow#set_cell ~pixmap:failedIcon i 3
- | "done " -> mainWindow#set_cell ~pixmap:doneIcon i 3
- | _ -> mainWindow#set_cell ~text:status i 3 in
+ | Failed -> mainWindow#set_cell ~pixmap:failedIcon i 3
+ | Done -> mainWindow#set_cell ~pixmap:doneIcon i 3
+ | NoStatus -> mainWindow#set_cell ~text:" " i 3 in
let displayMain() =
(* The call to mainWindow#clear below side-effect current,
@@ -1589,8 +1621,9 @@ lst_store#set ~row ~column:c_status status;
lst_store#set ~row ~column:c_path path;
*)
ignore (mainWindow#prepend
- [ r1; ""; r2; status; transcodeFilename path ]);
- displayArrow 0 i action
+ [ r1; ""; r2; ""; transcodeFilename path ]);
+ displayArrow 0 i action;
+ displayStatusIcon i status
done;
debug (fun()-> Util.msg "reset current to %s\n"
(match savedCurrent with None->"None" | Some(i) -> string_of_int i));
@@ -1609,11 +1642,10 @@ lst_store#set ~row ~column:c_path path;
mainWindow#set_cell ~text:r2 i 2;
displayStatusIcon i status;
mainWindow#set_cell ~text:(transcodeFilename path) i 4;
- if status = "failed" then begin
+ if status = Failed then
mainWindow#set_cell
~text:(transcodeFilename path ^
- " [failed: click on this line for details]") i 4
- end;
+ " [failed: click on this line for details]") i 4;
mainWindow#thaw ();
if !current = Some i then updateDetails ();
updateButtons () in
@@ -1621,11 +1653,10 @@ lst_store#set ~row ~column:c_path path;
let fastRedisplay i =
let (r1, action, r2, status, path) = columnsOf i in
displayStatusIcon i status;
- if status = "failed" then begin
+ if status = Failed then
mainWindow#set_cell
~text:(transcodeFilename path ^
- " [failed: click on this line for details]") i 4
- end;
+ " [failed: click on this line for details]") i 4;
if !current = Some i then updateDetails ();
in
@@ -1685,8 +1716,8 @@ lst_store#set ~row ~column:c_path path;
showGlobalProgress bytes;
gtk_sync false;
begin match item.ri.replicas with
- Different (_, _, dir, _) ->
- begin match !dir with
+ Different diff ->
+ begin match diff.direction with
Replica1ToReplica2 ->
if root2IsLocal then
clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes
@@ -1745,10 +1776,7 @@ lst_store#set ~row ~column:c_path path;
******************************************************************)
let detectUpdatesAndReconcile () =
- grSet grAction false;
- grSet grDiff false;
- grSet grGo false;
- grSet grRescan false;
+ grDisactivateAll ();
mainWindow#clear();
detailsWindow#buffer#set_text "";
@@ -1763,7 +1791,7 @@ lst_store#set ~row ~column:c_path path;
updates in
let reconcile updates =
let t = Trace.startTimer "Reconciling" in
- let reconRes = Recon.reconcileAll updates in
+ let reconRes = Recon.reconcileAll ~allowPartial:true updates in
Trace.showTimer t;
reconRes in
let (reconItemList, thereAreEqualUpdates, dangerousPaths) =
@@ -1871,10 +1899,7 @@ lst_store#set ~row ~column:c_path path;
if Array.length !theState = 0 then
Trace.status "Nothing to synchronize"
else begin
- grSet grAction false;
- grSet grDiff false;
- grSet grGo false;
- grSet grRescan false;
+ grDisactivateAll ();
Trace.status "Propagating changes";
Transport.logStart ();
@@ -2035,8 +2060,8 @@ lst_store#set ~row ~column:c_path path;
Some i ->
let theSI = !theState.(i) in
begin match theSI.whatHappened, theSI.ri.replicas with
- None, Different(_, _, dir, _) ->
- f dir;
+ None, Different diff ->
+ f diff;
redisplay i;
nextInteresting ()
| _ ->
@@ -2044,10 +2069,12 @@ lst_store#set ~row ~column:c_path path;
end
| None ->
() in
- let leftAction _ = doAction (fun dir -> dir := Replica2ToReplica1) in
- let rightAction _ = doAction (fun dir -> dir := Replica1ToReplica2) in
- let questionAction _ = doAction (fun dir -> dir := Conflict) in
- let mergeAction _ = doAction (fun dir -> dir := Merge) in
+ let leftAction _ =
+ doAction (fun diff -> diff.direction <- Replica2ToReplica1) in
+ let rightAction _ =
+ doAction (fun diff -> diff.direction <- Replica1ToReplica2) in
+ let questionAction _ = doAction (fun diff -> diff.direction <- Conflict) in
+ let mergeAction _ = doAction (fun diff -> diff.direction <- Merge) in
actionBar#insert_space ();
grAdd grAction
@@ -2107,6 +2134,15 @@ lst_store#set ~row ~column:c_path path;
~callback:mergeCmd ());
*)
(*********************************************************************
+ Detail button
+ *********************************************************************)
+ actionBar#insert_space ();
+ grAdd grDetail (actionBar#insert_button ~text:"Details"
+ ~icon:((GMisc.image ~stock:`INFO ())#coerce)
+ ~tooltip:"Show details"
+ ~callback:showDetCommand ());
+
+ (*********************************************************************
Keyboard commands
*********************************************************************)
ignore
@@ -2299,10 +2335,7 @@ lst_store#set ~row ~column:c_path path;
| Some(Util.Succeeded, _) -> false)
|| match !theState.(i).ri.replicas with
Problem _ -> true
- | Different(rc1,rc2,dir,_) ->
- (match !dir with
- Conflict -> true
- | _ -> false) in
+ | Different diff -> diff.direction = Conflict in
if notok then loop (i+1) (i::acc)
else loop (i+1) (acc) in
let failedindices = loop 0 [] in
@@ -2393,10 +2426,7 @@ lst_store#set ~row ~column:c_path path;
(*********************************************************************
Finish up
*********************************************************************)
- grSet grAction false;
- grSet grDiff false;
- grSet grGo false;
- grSet grRescan false;
+ grDisactivateAll ();
ignore (toplevelWindow#event#connect#delete ~callback:
(fun _ -> safeExit (); true));
diff --git a/src/uimacbridge.ml b/src/uimacbridge.ml
index b777287..fe5fa63 100644
--- a/src/uimacbridge.ml
+++ b/src/uimacbridge.ml
@@ -268,8 +268,8 @@ Callback.register "unisonRiToDetails" unisonRiToDetails;;
let unisonRiToPath ri = Path.toString ri.ri.path;;
Callback.register "unisonRiToPath" unisonRiToPath;;
-let rcToString (_,status,_,_) =
- match status with
+let rcToString rc =
+ match rc.status with
`Deleted -> "Deleted"
| `Modified -> "Modified"
| `PropsChanged -> "PropsChanged"
@@ -278,12 +278,12 @@ let rcToString (_,status,_,_) =
let unisonRiToLeft ri =
match ri.ri.replicas with
Problem _ -> ""
- | Different(rc,_,_,_) -> rcToString rc;;
+ | Different diff -> rcToString diff.rc1;;
Callback.register "unisonRiToLeft" unisonRiToLeft;;
let unisonRiToRight ri =
match ri.ri.replicas with
Problem _ -> ""
- | Different(_,rc,_,_) -> rcToString rc;;
+ | Different diff -> rcToString diff.rc2;;
Callback.register "unisonRiToRight" unisonRiToRight;;
let direction2niceString = function (* from Uicommon where it's not exported *)
@@ -294,28 +294,28 @@ let direction2niceString = function (* from Uicommon where it's not exported *)
let unisonRiToDirection ri =
match ri.ri.replicas with
Problem _ -> "XXXXX"
- | Different(_,_,d,_) -> direction2niceString !d;;
+ | Different diff -> direction2niceString diff.direction;;
Callback.register "unisonRiToDirection" unisonRiToDirection;;
let unisonRiSetLeft ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Replica2ToReplica1;;
+ | Different diff -> diff.direction <- Replica2ToReplica1;;
Callback.register "unisonRiSetLeft" unisonRiSetLeft;;
let unisonRiSetRight ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Replica1ToReplica2;;
+ | Different diff -> diff.direction <- Replica1ToReplica2;;
Callback.register "unisonRiSetRight" unisonRiSetRight;;
let unisonRiSetConflict ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Conflict;;
+ | Different diff -> diff.direction <- Conflict;;
Callback.register "unisonRiSetConflict" unisonRiSetConflict;;
let unisonRiSetMerge ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Merge;;
+ | Different diff -> diff.direction <- Merge;;
Callback.register "unisonRiSetMerge" unisonRiSetMerge;;
let unisonRiForceOlder ri =
Recon.setDirection ri.ri `Older `Force;;
@@ -328,7 +328,7 @@ let unisonRiToProgress ri =
match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with
(None,None,_) -> ""
| (Some s,None,_) -> s
- | (_,_,Different(_,_,{contents=Conflict},_)) -> ""
+ | (_,_,Different {direction = Conflict}) -> ""
| (_,_,Problem _) -> ""
| (_,Some Util.Succeeded,_) -> "done"
| (_,Some (Util.Failed s),_) -> "FAILED";;
@@ -469,12 +469,12 @@ Callback.register "unisonSecondRootString" unisonSecondRootString;;
the current setting is Conflict *)
let unisonRiIsConflict ri =
match ri.ri.replicas with
- | Different(_,_,_,Conflict) -> true
+ | Different {default_direction = Conflict} -> true
| _ -> false;;
Callback.register "unisonRiIsConflict" unisonRiIsConflict;;
let unisonRiRevert ri =
match ri.ri.replicas with
- | Different(_,_,d,d0) -> d := d0
+ | Different diff -> diff.direction <- diff.default_direction
| _ -> ();;
Callback.register "unisonRiRevert" unisonRiRevert;;
diff --git a/src/uimacbridgenew.ml b/src/uimacbridgenew.ml
index 9742d85..892eb5f 100644
--- a/src/uimacbridgenew.ml
+++ b/src/uimacbridgenew.ml
@@ -64,7 +64,7 @@ external displayStatus : string -> unit = "displayStatus";;
let callbackThreadCreate() =
let tCode () =
bridgeThreadWait 1;
- in Thread.create tCode (); Thread.create tCode ();
+ in ignore (Thread.create tCode ()); ignore (Thread.create tCode ());
let tid = Thread.create tCode ()
in Thread.join tid;
;;
@@ -337,8 +337,8 @@ Callback.register "unisonRiToDetails" unisonRiToDetails;;
let unisonRiToPath ri = Path.toString ri.ri.path;;
Callback.register "unisonRiToPath" unisonRiToPath;;
-let rcToString (_,status,_,_) =
- match status with
+let rcToString rc =
+ match rc.status with
`Deleted -> "Deleted"
| `Modified -> "Modified"
| `PropsChanged -> "PropsChanged"
@@ -347,12 +347,12 @@ let rcToString (_,status,_,_) =
let unisonRiToLeft ri =
match ri.ri.replicas with
Problem _ -> ""
- | Different(rc,_,_,_) -> rcToString rc;;
+ | Different {rc1 = rc} -> rcToString rc;;
Callback.register "unisonRiToLeft" unisonRiToLeft;;
let unisonRiToRight ri =
match ri.ri.replicas with
Problem _ -> ""
- | Different(_,rc,_,_) -> rcToString rc;;
+ | Different {rc2 = rc} -> rcToString rc;;
Callback.register "unisonRiToRight" unisonRiToRight;;
let unisonRiToFileSize ri =
@@ -371,28 +371,28 @@ let direction2niceString = function (* from Uicommon where it's not exported *)
let unisonRiToDirection ri =
match ri.ri.replicas with
Problem _ -> "XXXXX"
- | Different(_,_,d,_) -> direction2niceString !d;;
+ | Different diff -> direction2niceString diff.direction;;
Callback.register "unisonRiToDirection" unisonRiToDirection;;
let unisonRiSetLeft ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Replica2ToReplica1;;
+ | Different diff -> diff.direction <- Replica2ToReplica1;;
Callback.register "unisonRiSetLeft" unisonRiSetLeft;;
let unisonRiSetRight ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Replica1ToReplica2;;
+ | Different diff -> diff.direction <- Replica1ToReplica2;;
Callback.register "unisonRiSetRight" unisonRiSetRight;;
let unisonRiSetConflict ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Conflict;;
+ | Different diff -> diff.direction <- Conflict;;
Callback.register "unisonRiSetConflict" unisonRiSetConflict;;
let unisonRiSetMerge ri =
match ri.ri.replicas with
Problem _ -> ()
- | Different(_,_,d,_) -> d := Merge;;
+ | Different diff -> diff.direction <- Merge;;
Callback.register "unisonRiSetMerge" unisonRiSetMerge;;
let unisonRiForceOlder ri =
Recon.setDirection ri.ri `Older `Force;;
@@ -405,7 +405,7 @@ let unisonRiToProgress ri =
match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with
(None,None,_) -> ""
| (Some s,None,_) -> s
- | (_,_,Different(_,_,{contents=Conflict},_)) -> ""
+ | (_,_,Different {direction = Conflict}) -> ""
| (_,_,Problem _) -> ""
| (_,Some Util.Succeeded,_) -> "done"
| (_,Some (Util.Failed s),_) -> "FAILED";;
@@ -435,7 +435,8 @@ let filesAreDifferent status1 status2 =
let canDiff ri =
match ri.ri.replicas with
Problem _ -> false
- | Different((`FILE, status1, _, _),(`FILE, status2, _, _), _, _) ->
+ | Different {rc1 = {typ = `FILE; status = status1};
+ rc2 = {typ = `FILE; status = status2}} ->
filesAreDifferent status1 status2
| Different _ -> false;;
Callback.register "canDiff" canDiff;;
@@ -448,7 +449,9 @@ let showDiffs ri printer errprinter id =
Problem _ ->
errprinter
"Can't diff files: there was a problem during update detection"
- | Different((`FILE, status1, _, ui1), (`FILE, status2, _, ui2), _, _) ->
+ | Different
+ {rc1 = {typ = `FILE; status = status1; ui = ui1};
+ rc2 = {typ = `FILE; status = status2; ui = ui2}} ->
if filesAreDifferent status1 status2 then
(let (root1,root2) = Globals.roots() in
begin
@@ -619,7 +622,7 @@ Callback.register "unisonSecondRootString" unisonSecondRootString;;
the current setting is Conflict *)
let unisonRiIsConflict ri =
match ri.ri.replicas with
- | Different(_,_,_,Conflict) -> true
+ | Different {default_direction = Conflict} -> true
| _ -> false;;
Callback.register "unisonRiIsConflict" unisonRiIsConflict;;
@@ -628,13 +631,13 @@ Callback.register "unisonRiIsConflict" unisonRiIsConflict;;
the reconItems table *)
let changedFromDefault ri =
match ri.ri.replicas with
- Different(_,_,{contents=curr},default) -> curr<>default
+ Different diff -> diff.direction <> diff.default_direction
| _ -> false;;
Callback.register "changedFromDefault" changedFromDefault;;
let unisonRiRevert ri =
match ri.ri.replicas with
- | Different(_,_,d,d0) -> d := d0
+ | Different diff -> diff.direction <- diff.default_direction
| _ -> ();;
Callback.register "unisonRiRevert" unisonRiRevert;;
diff --git a/src/uitext.ml b/src/uitext.ml
index 7cb6abb..a75653c 100644
--- a/src/uitext.ml
+++ b/src/uitext.ml
@@ -171,26 +171,45 @@ let rec selectAction batch actions tryagain =
getInput ()
| Some i -> i)
+let alwaysDisplayErrors prefix l =
+ List.iter
+ (fun err -> alwaysDisplay (Format.sprintf "%s%s\n" prefix err)) l
+
let alwaysDisplayDetails ri =
- alwaysDisplay ((Uicommon.details2string ri " ") ^ "\n")
+ alwaysDisplay ((Uicommon.details2string ri " ") ^ "\n");
+ match ri.replicas with
+ Problem _ ->
+ ()
+ | Different diff ->
+ alwaysDisplayErrors "[root 1]: " diff.errors1;
+ alwaysDisplayErrors "[root 2]: " diff.errors2
let displayDetails ri =
if not (Prefs.read silent) then alwaysDisplayDetails ri
let displayri ri =
- let s = Uicommon.reconItem2string Path.empty ri "" ^ " " in
- let s =
+ let (r1, action, r2, path) = Uicommon.reconItem2stringList Path.empty ri in
+ let forced =
match ri.replicas with
- Different(_,_,d,def) when !d<>def ->
- let s = Util.replacesubstring s "<-?->" "<=?=>" in
- let s = Util.replacesubstring s "---->" "====>" in
- let s = Util.replacesubstring s "<----" "<====" in
- s
- | _ -> s in
+ Different diff -> diff.direction <> diff.default_direction
+ | Problem _ -> false
+ in
+ let (defaultAction, forcedAction) =
+ match action with
+ Uicommon.AError -> ("error", "error")
+ | Uicommon.ASkip _ -> ("<-?->", "<=?=>")
+ | Uicommon.ALtoR false -> ("---->", "====>")
+ | Uicommon.ALtoR true -> ("--?->", "==?=>")
+ | Uicommon.ARtoL false -> ("<----", "<====")
+ | Uicommon.ARtoL true -> ("<-?--", "<=?==")
+ | Uicommon.AMerge -> ("<-M->", "<=M=>")
+ in
+ let action = if forced then forcedAction else defaultAction in
+ let s = Format.sprintf "%s %s %s %s " r1 action r2 path in
match ri.replicas with
Problem _ ->
alwaysDisplay s
- | Different (_,_,d,_) when !d=Conflict ->
+ | Different {direction = d} when d=Conflict ->
alwaysDisplay s
| _ ->
display s
@@ -225,8 +244,8 @@ let interact rilist =
displayri ri;
match ri.replicas with
Problem s -> display "\n"; display s; display "\n"; next()
- | Different(rc1,rc2,dir,_) ->
- if Prefs.read Uicommon.auto && !dir<>Conflict then begin
+ | Different ({rc1 = rc1; rc2 = rc2; direction = dir} as diff) ->
+ if Prefs.read Uicommon.auto && dir<>Conflict then begin
display "\n"; next()
end else
let (descr, descl) =
@@ -243,14 +262,14 @@ let interact rilist =
end;
selectAction
(if Prefs.read Globals.batch then Some " " else None)
- [((if !dir=Conflict && not (Prefs.read Globals.batch)
+ [((if dir=Conflict && not (Prefs.read Globals.batch)
then ["f"] (* Offer no default behavior if we've got
a conflict and we're in interactive mode *)
else ["";"f";" "]),
("follow " ^ Uutil.myName ^ "'s recommendation (if any)"),
fun ()->
newLine ();
- if !dir = Conflict && not (Prefs.read Globals.batch)
+ if dir = Conflict && not (Prefs.read Globals.batch)
then begin
display "No default action [type '?' for help]\n";
repeat()
@@ -274,7 +293,7 @@ let interact rilist =
(["m"],
("merge the versions"),
(fun () ->
- dir := Merge;
+ diff.direction <- Merge;
redisplayri();
next()));
(["d"],
@@ -332,19 +351,19 @@ let interact rilist =
(["/"],
("skip"),
(fun () ->
- dir := Conflict;
+ diff.direction <- Conflict;
redisplayri();
next()));
([">";"."],
("propagate from " ^ descr),
(fun () ->
- dir := Replica1ToReplica2;
+ diff.direction <- Replica1ToReplica2;
redisplayri();
next()));
(["<";","],
("propagate from " ^ descl),
(fun () ->
- dir := Replica2ToReplica1;
+ diff.direction <- Replica2ToReplica1;
redisplayri();
next()))
]
@@ -612,7 +631,7 @@ let synchronizeOnce() =
Util.set_infos "";
let (reconItemList, anyEqualUpdates, dangerousPaths) =
- Recon.reconcileAll updates in
+ Recon.reconcileAll ~allowPartial:true updates in
if reconItemList = [] then begin
(if anyEqualUpdates then
diff --git a/src/update.ml b/src/update.ml
index c90d0f1..61af151 100644
--- a/src/update.ml
+++ b/src/update.ml
@@ -1646,8 +1646,10 @@ let commitUpdates () =
(* the result of patching [archive] using [ui] *)
let rec updateArchiveRec ui archive =
match ui with
- NoUpdates | Error _ ->
+ NoUpdates ->
archive
+ | Error _ ->
+ NoArchive
| Updates (uc, _) ->
match uc with
Absent ->
generated by cgit v1.1 at 2025-06-06 13:27:16 +0000