summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorJérôme Vouillon <vouillon@pps.jussieu.fr>2009-07-08 16:29:44 +0000
committerJérôme Vouillon <vouillon@pps.jussieu.fr>2009-07-08 16:29:44 +0000
commitcd2c0928e21058fd032ae6d8170dc9565ada3dd1 (patch)
tree6948ca0f6f9d5adf1de5d567632c369337ca0c72 /src
parent34ad46e46c7e854824e37bc8611cb8ae0660ad38 (diff)
downloadunison-cd2c0928e21058fd032ae6d8170dc9565ada3dd1.zip
unison-cd2c0928e21058fd032ae6d8170dc9565ada3dd1.tar.gz
unison-cd2c0928e21058fd032ae6d8170dc9565ada3dd1.tar.bz2
* 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.
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 ->