[Unison-hackers] [unison-svn] r403 - trunk/src
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Fri Jan 15 18:25:09 EST 2010
Author: vouillon
Date: 2010-01-15 18:25:09 -0500 (Fri, 15 Jan 2010)
New Revision: 403
Modified:
trunk/src/Makefile
trunk/src/RECENTNEWS
trunk/src/mkProjectInfo.ml
trunk/src/pred.ml
trunk/src/pred.mli
trunk/src/recon.ml
trunk/src/uicommon.ml
trunk/src/uimacbridge.ml
trunk/src/uimacbridgenew.ml
Log:
* Implemented 'partial' versions of 'noupdate', 'nodeletion' and 'nocreation'
* Check sooner (before connecting to another machine) that the roots
given as argument to all these preference are well-formed
Modified: trunk/src/Makefile
===================================================================
--- trunk/src/Makefile 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/Makefile 2010-01-15 23:25:09 UTC (rev 403)
@@ -60,11 +60,11 @@
# NAME, VERSION, and MAJORVERSION, automatically generated
-include Makefile.ProjectInfo
-Makefile.ProjectInfo: mkProjectInfo $(wildcard ../.bzr/branch/last-revision)
- ./mkProjectInfo > $@
+Makefile.ProjectInfo: mkProjectInfo.ml $(wildcard ../.bzr/branch/last-revision)
+ ocaml str.cma unix.cma ./mkProjectInfo.ml > $@
-mkProjectInfo: mkProjectInfo.ml
- ocamlc -o $@ unix.cma str.cma $^
+#mkProjectInfo: mkProjectInfo.ml
+# ocamlc -o $@ unix.cma str.cma $^
clean::
$(RM) mkProjectInfo
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/RECENTNEWS 2010-01-15 23:25:09 UTC (rev 403)
@@ -1,3 +1,9 @@
+CHANGES FROM VERSION 2.39.6
+
+* Implemented 'partial' versions of 'noupdate', 'nodeletion' and 'nocreation'
+* Check sooner (before connecting to another machine) that the roots
+ given as argument to all these preference are well-formed
+-------------------------------
CHANGES FROM VERSION 2.39.4
* New preferences "noupdate=root", "nodeletion=root", "nocreation=root"
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/mkProjectInfo.ml 2010-01-15 23:25:09 UTC (rev 403)
@@ -42,7 +42,7 @@
(* ---------------------------------------------------------------------- *)
(* You shouldn't need to edit below. *)
-let revisionString = "$Rev: 400$";;
+let revisionString = "$Rev: 402$";;
(* extract a substring using a regular expression *)
let extract_str re str =
@@ -97,9 +97,3 @@
Printf.printf "VERSION=%d.%d.%d\n" majorVersion minorVersion pointVersion;;
Printf.printf "NAME=%s\n" projectName;;
-
-
-
-
-
-
Modified: trunk/src/pred.ml
===================================================================
--- trunk/src/pred.ml 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/pred.ml 2010-01-15 23:25:09 UTC (rev 403)
@@ -88,9 +88,9 @@
end in
(compiled, v)
-let create name ?(advanced=false) fulldoc =
+let create name ?(local=false) ?(advanced=false) fulldoc =
let pref =
- Prefs.create name []
+ Prefs.create name ~local []
((if advanced then "!" else "")
^ "add a pattern to the " ^ name ^ " list")
fulldoc
@@ -111,15 +111,17 @@
let pref = Prefs.read p.pref in
let compiledList = Safelist.map compile_pattern (Safelist.append p.default pref) in
let compiled = Rx.alt (Safelist.map fst compiledList) in
+ let handleCase rx =
+ if (Case.ops())#caseInsensitiveMatch then Rx.case_insensitive rx
+ else rx
+ in
let strings = Safelist.filterMap
(fun (rx,vo) ->
match vo with
None -> None
- | Some v -> Some (rx,v))
+ | Some v -> Some (handleCase rx,v))
compiledList in
- p.compiled <-
- if (Case.ops())#caseInsensitiveMatch then Rx.case_insensitive compiled
- else compiled;
+ p.compiled <- handleCase compiled;
p.associated_strings <- strings;
p.last_pref <- pref;
p.last_def <- p.default;
@@ -160,3 +162,9 @@
recompile_if_needed p;
let s = (Case.ops())#normalizeMatchedString s in
snd (Safelist.find (fun (rx,v) -> Rx.match_string rx s) p.associated_strings)
+
+let assoc_all p s =
+ recompile_if_needed p;
+ let s = (Case.ops())#normalizeMatchedString s in
+ Safelist.map snd
+ (Safelist.filter (fun (rx,v) -> Rx.match_string rx s) p.associated_strings)
Modified: trunk/src/pred.mli
===================================================================
--- trunk/src/pred.mli 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/pred.mli 2010-01-15 23:25:09 UTC (rev 403)
@@ -30,7 +30,7 @@
(* Create a new predicate and register it with the preference module. The first
arg is the name of the predicate; the second is full (latex) documentation. *)
-val create : string -> ?advanced:bool -> string -> t
+val create : string -> ?local:bool -> ?advanced:bool -> string -> t
(* Check whether a given path matches one of the default or current patterns *)
val test : t -> string -> bool
@@ -39,6 +39,9 @@
if no pattern with an associated string matches. *)
val assoc : t -> string -> string
+(* Return all strings associated to a matching pattern. *)
+val assoc_all : t -> string -> string list
+
(* Add list of default patterns to the existing list. (These patterns are
remembered even when the associated preference is cleared). *)
val addDefaultPatterns : t -> string list -> unit
Modified: trunk/src/recon.ml
===================================================================
--- trunk/src/recon.ml 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/recon.ml 2010-01-15 23:25:09 UTC (rev 403)
@@ -96,7 +96,7 @@
let forceRootPartial: Pred.t =
Pred.create "forcepartial" ~advanced:true
- ("Including the preference \\texttt{forcepartial \\ARG{PATHSPEC} -> \\ARG{root}} causes Unison to "
+ ("Including the preference \\texttt{forcepartial = \\ARG{PATHSPEC} -> \\ARG{root}} causes Unison to "
^ "resolve all differences (even non-conflicting changes) in favor of "
^ "\\ARG{root} for the files in \\ARG{PATHSPEC} (see \\sectionref{pathspec}{Path Specification} "
^ "for more information). "
@@ -124,7 +124,7 @@
let preferRootPartial: Pred.t =
Pred.create "preferpartial" ~advanced:true
- ("Including the preference \\texttt{preferpartial \\ARG{PATHSPEC} -> \\ARG{root}} "
+ ("Including the preference \\texttt{preferpartial = \\ARG{PATHSPEC} -> \\ARG{root}} "
^ "causes Unison always to "
^ "resolve conflicts in favor of \\ARG{root}, rather than asking for "
^ "guidance from the user, for the files in \\ARG{PATHSPEC} (see "
@@ -156,39 +156,11 @@
else
("",`Prefer)
-let actionKind fromRc toRc =
- let fromTyp = fromRc.typ in
- let toTyp = toRc.typ in
- if fromTyp = toTyp then `UPDATE else
- if toTyp = `ABSENT then `CREATION else
- `DELETION
-
-type prefs = { noDeletion : bool; noUpdate: bool; noCreation : bool }
-
-let shouldCancel rc1 rc2 prefs =
- match actionKind rc1 rc2 with
- `UPDATE -> prefs.noUpdate
- | `DELETION -> prefs.noUpdate || prefs.noDeletion
- | `CREATION -> prefs.noCreation
-
-let filterRi prefs1 prefs2 ri =
- match ri.replicas with
- Problem _ ->
- ()
- | Different diff ->
- if
- match diff.direction with
- Replica1ToReplica2 -> shouldCancel diff.rc1 diff.rc2 prefs2
- | Replica2ToReplica1 -> shouldCancel diff.rc2 diff.rc1 prefs1
- | Conflict | Merge -> false
- then
- diff.direction <- Conflict
-
let noDeletion =
Prefs.createStringList "nodeletion" ~local:true
"prevent file deletions on one replica"
("Including the preference \\texttt{-nodeletion \\ARG{root}} prevents \
- Unison from performing any file deletion on root \\ARG{root}.\n\
+ Unison from performing any file deletion on root \\ARG{root}.\n\n\
This preference can be included twice, once for each root, if you \
want to prevent any creation.")
@@ -197,7 +169,7 @@
"prevent file updates and deletions on one replica"
("Including the preference \\texttt{-noupdate \\ARG{root}} prevents \
Unison from performing any file update or deletion on root \
- \\ARG{root}.\n\
+ \\ARG{root}.\n\n\
This preference can be included twice, once for each root, if you \
want to prevent any update.")
@@ -205,21 +177,83 @@
Prefs.createStringList "nocreation" ~local:true
"prevent file creations on one replica"
("Including the preference \\texttt{-nocreation \\ARG{root}} prevents \
- Unison from performing any file creation on root \\ARG{root}.\n\
+ Unison from performing any file creation on root \\ARG{root}.\n\n\
This preference can be included twice, once for each root, if you \
want to prevent any creation.")
+let noDeletionPartial =
+ Pred.create "nodeletionpartial" ~local:true ~advanced:true
+ ("Including the preference \
+ \\texttt{nodeletionpartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \
+ Unison from performing any file deletion in \\ARG{PATHSPEC} \
+ on root \\ARG{root} (see \\sectionref{pathspec}{Path Specification} \
+ for more information).")
+
+let noUpdatePartial =
+ Pred.create "noupdatepartial" ~local:true ~advanced:true
+ ("Including the preference \
+ \\texttt{noupdatepartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \
+ Unison from performing any file update or deletion in \
+ \\ARG{PATHSPEC} on root \\ARG{root} (see \
+ \\sectionref{pathspec}{Path Specification} for more information).")
+
+let noCreationPartial =
+ Pred.create "nocreationpartial" ~local:true ~advanced:true
+ ("Including the preference \
+ \\texttt{nocreationpartial = \\ARG{PATHSPEC} -> \\ARG{root}} prevents \
+ Unison from performing any file creation in \\ARG{PATHSPEC} \
+ on root \\ARG{root} (see \\sectionref{pathspec}{Path Specification} \
+ for more information).")
+
+let partialCancelPref actionKind =
+ match actionKind with
+ `DELETION -> noDeletionPartial
+ | `UPDATE -> noUpdatePartial
+ | `CREATION -> noCreationPartial
+
+let cancelPref actionKind =
+ match actionKind with
+ `DELETION -> noDeletion
+ | `UPDATE -> noUpdate
+ | `CREATION -> noCreation
+
+let actionKind fromRc toRc =
+ let fromTyp = fromRc.typ in
+ let toTyp = toRc.typ in
+ if fromTyp = toTyp then `UPDATE else
+ if toTyp = `ABSENT then `CREATION else
+ `DELETION
+
+let shouldCancel path rc1 rc2 root2 =
+ let test kind =
+ List.mem root2 (Prefs.read (cancelPref kind))
+ ||
+ List.mem root2 (Pred.assoc_all (partialCancelPref kind) path)
+ in
+ match actionKind rc1 rc2 with
+ `UPDATE -> test `UPDATE
+ | `DELETION -> test `UPDATE || test `DELETION
+ | `CREATION -> test `CREATION
+
+let filterRi root1 root2 ri =
+ match ri.replicas with
+ Problem _ ->
+ ()
+ | Different diff ->
+ if
+ match diff.direction with
+ Replica1ToReplica2 ->
+ shouldCancel (Path.toString ri.path1) diff.rc1 diff.rc2 root2
+ | Replica2ToReplica1 ->
+ shouldCancel (Path.toString ri.path1) diff.rc2 diff.rc1 root1
+ | Conflict | Merge ->
+ false
+ then
+ diff.direction <- Conflict
+
let filterRis ris =
let (root1, root2) = Globals.rawRootPair () in
- let getPref root pref = List.mem root (Prefs.read pref) in
- let getPrefs root =
- { noDeletion = getPref root noDeletion;
- noUpdate = getPref root noUpdate;
- noCreation = getPref root noCreation }
- in
- let prefs1 = getPrefs root1 in
- let prefs2 = getPrefs root2 in
- Safelist.iter (fun ri -> filterRi prefs1 prefs2 ri) ris
+ Safelist.iter (fun ri -> filterRi root1 root2 ri) ris
(* Use the current values of the '-prefer <ROOT>' and '-force <ROOT>' *)
(* preferences to override the reconciler's choices *)
@@ -253,11 +287,11 @@
if root<>"" then test_root (match pred with `Force -> "force" | `Prefer -> "prefer") root;
Safelist.iter (test_root "forcepartial") (Pred.extern_associated_strings forceRootPartial);
Safelist.iter (test_root "preferpartial") (Pred.extern_associated_strings preferRootPartial);
- let checkPref pref prefName =
+ let checkPref extract (pref, prefName) =
try
let root =
List.find (fun r -> not (List.mem r (Globals.rawRoots ())))
- (Prefs.read pref)
+ (extract pref)
in
let (r1, r2) = Globals.rawRootPair () in
raise (Util.Fatal (Printf.sprintf
@@ -266,9 +300,12 @@
with Not_found ->
()
in
- checkPref noDeletion "nodeletion";
- checkPref noUpdate "noupdate";
- checkPref noCreation "nocreation"
+ List.iter (checkPref Prefs.read)
+ [noDeletion, "nodeletion"; noUpdate, "noupdate"; noCreation, "nocreation"];
+ List.iter (checkPref Pred.extern_associated_strings)
+ [noDeletionPartial, "nodeletionpartial";
+ noUpdatePartial, "noupdatepartial";
+ noCreationPartial, "nocreationpartial"]
(* ------------------------------------------------------------------------- *)
(* Main Reconciliation stuff *)
Modified: trunk/src/uicommon.ml
===================================================================
--- trunk/src/uicommon.ml 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/uicommon.ml 2010-01-15 23:25:09 UTC (rev 403)
@@ -545,6 +545,8 @@
promptForRoots getFirstRoot getSecondRoot;
end;
+ Recon.checkThatPreferredRootIsValid();
+
(* The following step contacts the server, so warn the user it could take
some time *)
if not (Prefs.read contactquietly || Prefs.read Trace.terse) then
@@ -597,8 +599,6 @@
Printf.eprintf " %s\n" (root2string r))
(Globals.rootsInCanonicalOrder());
Printf.eprintf "\n");
-
- Recon.checkThatPreferredRootIsValid();
Lwt_unix.run
(validateAndFixupPrefs () >>=
Modified: trunk/src/uimacbridge.ml
===================================================================
--- trunk/src/uimacbridge.ml 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/uimacbridge.ml 2010-01-15 23:25:09 UTC (rev 403)
@@ -153,6 +153,9 @@
Trace.debug "" (fun() -> Prefs.dumpPrefsToStderr() );
(* FIX: if no roots, ask the user *)
+
+ Recon.checkThatPreferredRootIsValid();
+
let localRoots,remoteRoots =
Safelist.partition
(function Clroot.ConnectLocal _ -> true | _ -> false)
@@ -207,8 +210,6 @@
Printf.eprintf "\n"
);
- Recon.checkThatPreferredRootIsValid();
-
Lwt_unix.run
(Uicommon.validateAndFixupPrefs () >>=
Globals.propagatePrefs);
Modified: trunk/src/uimacbridgenew.ml
===================================================================
--- trunk/src/uimacbridgenew.ml 2010-01-15 15:28:23 UTC (rev 402)
+++ trunk/src/uimacbridgenew.ml 2010-01-15 23:25:09 UTC (rev 403)
@@ -224,6 +224,9 @@
Trace.debug "" (fun() -> Prefs.dumpPrefsToStderr() );
(* FIX: if no roots, ask the user *)
+
+ Recon.checkThatPreferredRootIsValid();
+
let localRoots,remoteRoots =
Safelist.partition
(function Clroot.ConnectLocal _ -> true | _ -> false)
@@ -293,8 +296,6 @@
Printf.eprintf "\n"
);
- Recon.checkThatPreferredRootIsValid();
-
Lwt_unix.run
(Uicommon.validateAndFixupPrefs () >>=
Globals.propagatePrefs);
More information about the Unison-hackers
mailing list