[Unison-hackers] [unison-svn] r459 - in trunk/src: . ubase

bcpierce@seas.upenn.edu bcpierce at seas.upenn.edu
Sat Jul 24 08:19:38 EDT 2010


Author: bcpierce
Date: 2010-07-24 08:19:38 -0400 (Sat, 24 Jul 2010)
New Revision: 459

Modified:
   trunk/src/RECENTNEWS
   trunk/src/copy.ml
   trunk/src/fileinfo.mli
   trunk/src/fingerprint.ml
   trunk/src/fingerprint.mli
   trunk/src/fpcache.ml
   trunk/src/fpcache.mli
   trunk/src/mkProjectInfo.ml
   trunk/src/os.ml
   trunk/src/os.mli
   trunk/src/stasher.ml
   trunk/src/test.ml
   trunk/src/ubase/trace.ml
   trunk/src/update.ml
   trunk/src/xferhint.mli
Log:
* Experimental implementation of a new "faster check" mode for update
  detection.  When this mode is enabled (by running with
  'fastercheckUNSAFE=true'), Unison will skip calculating fingerprints
  of the contents of files that it has not seen before -- it just uses
  the file's size as a pseudo-fingerprint, allowing the archives to be
  built very quickly.  

  This feature has not been extensively tested -- if you use it on
  live replicas, please pay careful attention to what Unison is doing.
  Also, note that the cost of faster update detection is that it is
  possible Unison will miss a conflict; this flag should be used only
  when the replicas are known to be identical.

  Here's the full documentation.  

let fastercheckUNSAFE =
  Prefs.createBool "fastercheckUNSAFE"
    false "!skip computing fingerprints for new files (experts only!)"
    (  "THIS FEATURE IS STILL EXPERIMENTAL AND SHOULD BE USED WITH EXTREME CAUTION.  "
       ^ "\n\n"
       ^ "When this flag is set to {\\tt true}, Unison will compute a 'pseudo-" 
       ^ "fingerprint' the first time it sees a file (either because the file is "
       ^ "new or because Unison is running for the first time).  This enormously "
       ^ "speeds update detection, but it must be used with care, as it can cause "
       ^ "Unison to miss conflicts: If "
       ^ "a given path in the filesystem contains files on {\\em both} sides that "
       ^ "Unison has not yet seen, and if those files have the same length but different "
       ^ "contents, then Unison will not notice the presence of a conflict.  If, later, one "
       ^ "of the files is changed, the changed file will be propagated, overwriting  "
       ^ "the other.  "
       ^ "\n\n"
       ^ "Moreover, even when the files are initially identical, setting this flag can lead "
       ^ "to potentially confusing behavior: "
       ^ "if a newly created file is later touched without being modified, Unison will "
       ^ "treat this "
       ^ "conservatively as a potential change (since it has no record of the earlier "
       ^ "contents) and show it as needing to be propagated to the other replica. "
       ^ "\n\n"
       ^ "Most users should leave this flag off -- the small time savings of not "
       ^ "fingerprinting new files is not worth the cost in terms of safety.  However, "
       ^ "it can be very useful for power users with huge replicas that are known to "
       ^ "be already synchronized (e.g., because one replica is a newly created duplicate "
       ^ "of the other, or because they have previously been synchronized with Unison but "
       ^ "Unison's archives need to be rebuilt).  In such situations, it is recommended "
       ^ "that this flag be set only for the initial run of Unison, so that new archives "
       ^ "can be created quickly, and then turned off for normal use.")


Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/RECENTNEWS	2010-07-24 12:19:38 UTC (rev 459)
@@ -1,3 +1,53 @@
+CHANGES FROM VERSION 2.43.-30
+
+* Experimental implementation of a new "faster check" mode for update
+  detection.  When this mode is enabled (by running with
+  'fastercheckUNSAFE=true'), Unison will skip calculating fingerprints
+  of the contents of files that it has not seen before -- it just uses
+  the file's size as a pseudo-fingerprint, allowing the archives to be
+  built very quickly.  
+
+  This feature has not been extensively tested -- if you use it on
+  live replicas, please pay careful attention to what Unison is doing.
+  Also, note that the cost of faster update detection is that it is
+  possible Unison will miss a conflict; this flag should be used only
+  when the replicas are known to be identical.
+
+  Here's the full documentation.  
+
+let fastercheckUNSAFE =
+  Prefs.createBool "fastercheckUNSAFE"
+    false "!skip computing fingerprints for new files (experts only!)"
+    (  "THIS FEATURE IS STILL EXPERIMENTAL AND SHOULD BE USED WITH EXTREME CAUTION.  "
+       ^ "\n\n"
+       ^ "When this flag is set to {\\tt true}, Unison will compute a 'pseudo-" 
+       ^ "fingerprint' the first time it sees a file (either because the file is "
+       ^ "new or because Unison is running for the first time).  This enormously "
+       ^ "speeds update detection, but it must be used with care, as it can cause "
+       ^ "Unison to miss conflicts: If "
+       ^ "a given path in the filesystem contains files on {\\em both} sides that "
+       ^ "Unison has not yet seen, and if those files have the same length but different "
+       ^ "contents, then Unison will not notice the presence of a conflict.  If, later, one "
+       ^ "of the files is changed, the changed file will be propagated, overwriting  "
+       ^ "the other.  "
+       ^ "\n\n"
+       ^ "Moreover, even when the files are initially identical, setting this flag can lead "
+       ^ "to potentially confusing behavior: "
+       ^ "if a newly created file is later touched without being modified, Unison will "
+       ^ "treat this "
+       ^ "conservatively as a potential change (since it has no record of the earlier "
+       ^ "contents) and show it as needing to be propagated to the other replica. "
+       ^ "\n\n"
+       ^ "Most users should leave this flag off -- the small time savings of not "
+       ^ "fingerprinting new files is not worth the cost in terms of safety.  However, "
+       ^ "it can be very useful for power users with huge replicas that are known to "
+       ^ "be already synchronized (e.g., because one replica is a newly created duplicate "
+       ^ "of the other, or because they have previously been synchronized with Unison but "
+       ^ "Unison's archives need to be rebuilt).  In such situations, it is recommended "
+       ^ "that this flag be set only for the initial run of Unison, so that new archives "
+       ^ "can be created quickly, and then turned off for normal use.")
+
+-------------------------------
 CHANGES FROM VERSION 2.43.-29
 
 * Added support for "pseudo-fingerprints", as a first step to

Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/copy.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -67,7 +67,7 @@
          None dataClearlyUnchanged
   in
   if dataClearlyUnchanged && ressClearlyUnchanged then begin
-    if paranoid then begin
+    if paranoid && not (Os.isPseudoFingerprint archDig) then begin
       let newDig = Os.fingerprint fspathFrom pathFrom info in
       if archDig <> newDig then begin
         Update.markPossiblyUpdated fspathFrom pathFrom;
@@ -164,7 +164,7 @@
 let paranoidCheck fspathTo pathTo realPathTo desc fp ress =
   let info = Fileinfo.get false fspathTo pathTo in
   let fp' = Os.fingerprint fspathTo pathTo info in
-  if fp' <> fp then begin
+  if fp' <> fp (* && not (Os.isPseudoFingerprint fp) *) then begin
     Lwt.return (Failure (Os.reasonForFingerprintMismatch fp fp'))
   end else
     Lwt.return (Success info)
@@ -922,7 +922,7 @@
       localFile
         fspathFrom pathFrom fspathTo pathTo realPathTo
         update desc (Osx.ressLength ress) (Some id);
-      paranoidCheck fspathTo pathTo realPathTo desc fp ress
+        paranoidCheck fspathTo pathTo realPathTo desc fp ress
   | _ ->
       transferFile
         rootFrom pathFrom rootTo fspathTo pathTo realPathTo

Modified: trunk/src/fileinfo.mli
===================================================================
--- trunk/src/fileinfo.mli	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/fileinfo.mli	2010-07-24 12:19:38 UTC (rev 459)
@@ -6,7 +6,7 @@
 
 type t = { typ : typ; inode : int; desc : Props.t; osX : Osx.info}
 
-val get : bool -> Fspath.t -> Path.local -> t
+val get : bool (* fromRoot *) -> Fspath.t -> Path.local -> t
 val set : Fspath.t -> Path.local ->
           [`Set of Props.t | `Copy of Path.local | `Update of Props.t] ->
           Props.t -> unit

Modified: trunk/src/fingerprint.ml
===================================================================
--- trunk/src/fingerprint.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/fingerprint.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -19,6 +19,13 @@
 (* INCREMENT "UPDATE.ARCHIVEFORMAT"                                          *)
 type t = string
 
+let pseudo_prefix = "LEN" 
+
+let pseudo path len = pseudo_prefix ^ (Uutil.Filesize.toString len) ^ "@" ^
+                      (Path.toString path)
+                                    
+let ispseudo f = Util.startswith f pseudo_prefix 
+
 (* Assumes that (fspath, path) is a file and gives its ``digest '', that is  *)
 (* a short string of cryptographic quality representing it.                  *)
 let file fspath path =
@@ -66,14 +73,16 @@
   (int2hexa first, int2hexa second)
 
 let toString md5 =
-  let length = String.length md5 in
-  let string = String.create (length * 2) in
-  for i=0 to (length - 1) do
-    let c1, c2 =  hexaCode (md5.[i]) in
-    string.[2*i] <- c1;
-    string.[2*i + 1] <- c2;
-  done;
-  string
+  if ispseudo md5 then md5 else begin
+    let length = String.length md5 in
+    let string = String.create (length * 2) in
+    for i=0 to (length - 1) do
+      let c1, c2 =  hexaCode (md5.[i]) in
+      string.[2*i] <- c1;
+      string.[2*i + 1] <- c2;
+    done;
+    string
+  end 
 
 let string = Digest.string
 
@@ -92,8 +101,3 @@
 
 let equal (d : string) d' = d = d'
 
-let pseudo_prefix = "LEN" 
-
-let pseudo len = pseudo_prefix ^ (Uutil.Filesize.toString len)
-                                    
-let ispseudo f = Util.startswith f pseudo_prefix 

Modified: trunk/src/fingerprint.mli
===================================================================
--- trunk/src/fingerprint.mli	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/fingerprint.mli	2010-07-24 12:19:38 UTC (rev 459)
@@ -21,5 +21,5 @@
 (* A pseudo-fingerprint has the same type as a real one (so it can
    be stored in the archive, etc.), but it is computed just from the
    size of the file, ignoring the contents *)
-val pseudo : Uutil.Filesize.t -> t
+val pseudo : Path.local -> Uutil.Filesize.t -> t
 val ispseudo : t -> bool

Modified: trunk/src/fpcache.ml
===================================================================
--- trunk/src/fpcache.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/fpcache.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -128,9 +128,9 @@
 
 let magic = "Unison fingerprint cache format 2"
 
-let init fastCheck fspath =
+let init fastCheck ignorearchives fspath =
   finish ();
-  if fastCheck then begin
+  if fastCheck && not ignorearchives then begin
     begin try
       debug (fun () -> Util.msg "opening cache file %s for input\n"
                          (System.fspathToDebugString fspath));
@@ -235,7 +235,7 @@
   in
   du && ressClearlyUnchanged fastCheck newInfo oldRess du
 
-let fingerprint fastCheck currfspath path info optDig =
+let fingerprint ?(newfile=false) fastCheck currfspath path info optDig =
   let res =
     try
       let (oldDesc, oldDig, oldStamp, oldRess) as res =
@@ -251,7 +251,8 @@
       if fastCheck then
         debug (fun () -> Util.msg "cache miss for path %s\n"
                            (Path.toDebugString path));
-      let (info, dig) = Os.safeFingerprint currfspath path info optDig in
+      let (info, dig) =
+        Os.safeFingerprint ~newfile currfspath path info optDig in
       (info.Fileinfo.desc, dig, Fileinfo.stamp info, Fileinfo.ressStamp info)
   in
   save path res;

Modified: trunk/src/fpcache.mli
===================================================================
--- trunk/src/fpcache.mli	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/fpcache.mli	2010-07-24 12:19:38 UTC (rev 459)
@@ -2,13 +2,14 @@
 (* Copyright 1999-2010, Benjamin C. Pierce (see COPYING for details) *)
 
 (* Initialize the cache *)
-val init : bool -> System.fspath -> unit
+val init : bool -> bool -> System.fspath -> unit
 
 (* Close the cache file and clear the in-memory cache *)
 val finish : unit -> unit
 
 (* Get the fingerprint of a file, possibly from the cache *)
 val fingerprint :
+  ?newfile:bool ->
   bool -> Fspath.t -> Path.local -> Fileinfo.t -> Os.fullfingerprint option ->
   Props.t * Os.fullfingerprint * Fileinfo.stamp * Osx.ressStamp
 

Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/mkProjectInfo.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -6,7 +6,7 @@
 let projectName = "unison"
 let majorVersion = 2
 let minorVersion = 43
-let pointVersionOrigin = 454 (* Revision that corresponds to point version 0 *)
+let pointVersionOrigin = 455 (* Revision that corresponds to point version 0 *)
 
 (* Documentation:
    This is a program to construct a version of the form Major.Minor.Point,
@@ -59,3 +59,4 @@
 
 
 
+

Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/os.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -224,39 +224,83 @@
   (Fingerprint.file fspath path,
    Osx.ressFingerprint fspath path info.Fileinfo.osX)
 
+let fastercheckUNSAFE =
+  Prefs.createBool "fastercheckUNSAFE"
+    false "!skip computing fingerprints for new files (experts only!)"
+    (  "THIS FEATURE IS STILL EXPERIMENTAL AND SHOULD BE USED WITH EXTREME CAUTION.  "
+       ^ "\n\n"
+       ^ "When this flag is set to {\\tt true}, Unison will compute a 'pseudo-" 
+       ^ "fingerprint' the first time it sees a file (either because the file is "
+       ^ "new or because Unison is running for the first time).  This enormously "
+       ^ "speeds update detection, but it must be used with care, as it can cause "
+       ^ "Unison to miss conflicts: If "
+       ^ "a given path in the filesystem contains files on {\\em both} sides that "
+       ^ "Unison has not yet seen, and if those files have the same length but different "
+       ^ "contents, then Unison will not notice the presence of a conflict.  If, later, one "
+       ^ "of the files is changed, the changed file will be propagated, overwriting  "
+       ^ "the other.  "
+       ^ "\n\n"
+       ^ "Moreover, even when the files are initially identical, setting this flag can lead "
+       ^ "to potentially confusing behavior: "
+       ^ "if a newly created file is later touched without being modified, Unison will "
+       ^ "treat this "
+       ^ "conservatively as a potential change (since it has no record of the earlier "
+       ^ "contents) and show it as needing to be propagated to the other replica. "
+       ^ "\n\n"
+       ^ "Most users should leave this flag off -- the small time savings of not "
+       ^ "fingerprinting new files is not worth the cost in terms of safety.  However, "
+       ^ "it can be very useful for power users with huge replicas that are known to "
+       ^ "be already synchronized (e.g., because one replica is a newly created duplicate "
+       ^ "of the other, or because they have previously been synchronized with Unison but "
+       ^ "Unison's archives need to be rebuilt).  In such situations, it is recommended "
+       ^ "that this flag be set only for the initial run of Unison, so that new archives "
+       ^ "can be created quickly, and then turned off for normal use.")
+
+let pseudoFingerprint path size =
+  (Fingerprint.pseudo path size, Fingerprint.dummy)
+
+let isPseudoFingerprint (fp,rfp) =
+  Fingerprint.ispseudo fp
+
 (* FIX: not completely safe under Unix                                       *)
 (* (with networked file system such as NFS)                                  *)
-let safeFingerprint fspath path info optDig =
-  let rec retryLoop count info optDig optRessDig =
-    if count = 0 then
-      raise (Util.Transient
-               (Printf.sprintf
-                  "Failed to fingerprint file \"%s\": \
-                   the file keeps on changing"
-                  (Fspath.toPrintString (Fspath.concat fspath path))))
-    else
-      let dig =
-        match optDig with
-          None     -> Fingerprint.file fspath path
-        | Some dig -> dig
-      in
-      let ressDig =
-        match optRessDig with
-          None      -> Osx.ressFingerprint fspath path info.Fileinfo.osX
-        | Some ress -> ress
-      in
-      let (info', dataUnchanged, ressUnchanged) =
-        Fileinfo.unchanged fspath path info in
-      if dataUnchanged && ressUnchanged then
-        (info', (dig, ressDig))
+let safeFingerprint ?(newfile=false) fspath path info optDig =
+  if Prefs.read fastercheckUNSAFE && newfile then begin
+    debug (fun()-> Util.msg "skipping initial fingerprint of %s\n"
+                      (Fspath.toDebugString (Fspath.concat fspath path)));
+    let info = Fileinfo.get false fspath path in
+    (info, pseudoFingerprint path (Props.length info.Fileinfo.desc))
+  end else 
+    let rec retryLoop count info optDig optRessDig =
+      if count = 0 then
+        raise (Util.Transient
+                 (Printf.sprintf
+                    "Failed to fingerprint file \"%s\": \
+                     the file keeps on changing"
+                    (Fspath.toPrintString (Fspath.concat fspath path))))
       else
-        retryLoop (count - 1) info'
-          (if dataUnchanged then Some dig else None)
-          (if ressUnchanged then Some ressDig else None)
-  in
-  retryLoop 10 info (* Maximum retries: 10 times *)
-    (match optDig with None -> None | Some (d, _) -> Some d)
-    None
+        let dig =
+          match optDig with
+            None     -> Fingerprint.file fspath path
+          | Some dig -> dig
+        in
+        let ressDig =
+          match optRessDig with
+            None      -> Osx.ressFingerprint fspath path info.Fileinfo.osX
+          | Some ress -> ress
+        in
+        let (info', dataUnchanged, ressUnchanged) =
+          Fileinfo.unchanged fspath path info in
+        if dataUnchanged && ressUnchanged then
+          (info', (dig, ressDig))
+        else
+          retryLoop (count - 1) info'
+            (if dataUnchanged then Some dig else None)
+            (if ressUnchanged then Some ressDig else None)
+    in
+    retryLoop 10 info (* Maximum retries: 10 times *)
+      (match optDig with None -> None | Some (d, _) -> Some d)
+      None
 
 let fullfingerprint_to_string (fp,rfp) =
   Printf.sprintf "(%s,%s)" (Fingerprint.toString fp) (Fingerprint.toString rfp)
@@ -274,13 +318,7 @@
 let fullfingerprintEqual (fp, rfp) (fp', rfp') =
   Fingerprint.equal fp fp' && Fingerprint.equal rfp rfp'
 
-let pseudoFingerprint size =
-  (Fingerprint.pseudo size, Fingerprint.dummy)
 
-let isPseudoFingerprint (fp,rfp) =
-  Fingerprint.ispseudo fp
-
-
 (*****************************************************************************)
 (*                           UNISON DIRECTORY                                *)
 (*****************************************************************************)

Modified: trunk/src/os.mli
===================================================================
--- trunk/src/os.mli	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/os.mli	2010-07-24 12:19:38 UTC (rev 459)
@@ -36,6 +36,7 @@
 
 (* Use this function if the file may change during fingerprinting *)
 val safeFingerprint :
+  ?newfile:bool ->          (* true if this file is new; false by default *)
   Fspath.t -> Path.local -> (* coordinates of file to fingerprint *)
   Fileinfo.t ->             (* old fileinfo *)
   fullfingerprint option -> (* fingerprint corresponding to the old fileinfo *)
@@ -46,10 +47,12 @@
   Fileinfo.t ->             (* old fileinfo *)
   fullfingerprint           (* current fingerprint *)
 
+(* BCP: Not sure this needs to be exported
 val pseudoFingerprint :
   Uutil.Filesize.t       -> (* size of file to "fingerprint" *)
   fullfingerprint           (* pseudo-fingerprint of this file (containing just
                                the file's length) *)
+*)
 
 val isPseudoFingerprint :
   fullfingerprint -> bool

Modified: trunk/src/stasher.ml
===================================================================
--- trunk/src/stasher.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/stasher.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -484,6 +484,9 @@
     let rec aux_find i =
       let path = makeBackupName path i in
       if Os.exists dir path &&
+        (* FIX: should check that the existing file has the same size, to 
+           avoid computing the fingerprint if it is obviously going to be
+           different... *)
 	(let dig = Os.fingerprint dir path (Fileinfo.get false dir path) in 
  	 dig = fingerprint)
       then begin

Modified: trunk/src/test.ml
===================================================================
--- trunk/src/test.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/test.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -340,6 +340,31 @@
     );
 
   if bothRootsLocal then 
+    runtest "fastercheckUNSAFE 1" ["fastercheckUNSAFE = true"] (fun() -> 
+      put R1 (Dir []); put R2 (Dir []); sync();
+      (* Create a file on both sides with different contents *)
+      put R1 (Dir ["x", File "foo"]); 
+      put R2 (Dir ["x", File "bar"]); sync();
+      check "1a" R1 (Dir ["x", File "foo"]);
+      check "1b" R2 (Dir ["x", File "bar"]);
+      (* Change contents on one side and see that we do NOT get a conflict (!) *)
+      put R1 (Dir ["x", File "newcontents"]); sync();
+      check "2a" R1 (Dir ["x", File "newcontents"]);
+      check "2b" R2 (Dir ["x", File "newcontents"]);
+      (* Start again *)
+      put R1 (Dir []); put R2 (Dir []); sync();
+      (* Create a file on both sides with different contents *)
+      put R1 (Dir ["x", File "foo"]); 
+      put R2 (Dir ["x", File "bar"]); sync();
+      (* Change contents without changing size and check that change is propagated *)
+      put R1 (Dir ["x", File "f00"]); sync();
+      check "3a" R1 (Dir ["x", File "f00"]);
+      check "3b" R2 (Dir ["x", File "f00"]);
+    );
+
+  raise (Util.Fatal "Skipping some tests -- remove me!\n"); 
+
+  if bothRootsLocal then 
     runtest "backups 1 (local)" ["backup = Name *"] (fun() -> 
       put R1 (Dir []); put R2 (Dir []); sync();
       (* Create a file and a directory *)

Modified: trunk/src/ubase/trace.ml
===================================================================
--- trunk/src/ubase/trace.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/ubase/trace.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -48,7 +48,7 @@
 let debugtimes =
   Prefs.createBool "debugtimes"
     false "*annotate debugging messages with timestamps" ""
-
+                                   
 let runningasserver = ref false
 
 let debugging() = (Prefs.read debugmods) <> []

Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/update.ml	2010-07-24 12:19:38 UTC (rev 459)
@@ -23,6 +23,15 @@
 let debugalias = Trace.debug "rootalias"
 let debugignore = Trace.debug "ignore"
 
+let ignoreArchives =
+  Prefs.createBool "ignorearchives" false
+    "!ignore existing archive files"
+    ("When this preference is set, Unison will ignore any existing "
+     ^ "archive files and behave as though it were being run for the first "
+     ^ "time on these replicas.  It is "
+     ^ "not a good idea to set this option in a profile: it is intended for "
+     ^ "command-line use.")
+
 (*****************************************************************************)
 (*                             ARCHIVE DATATYPE                              *)
 (*****************************************************************************)
@@ -652,7 +661,7 @@
 let populateCacheFromArchive fspath arch =
   let (cacheFilename, _) = archiveName fspath FPCache in
   let cacheFile = Os.fileInUnisonDir cacheFilename in
-  Fpcache.init true cacheFile;
+  Fpcache.init true (Prefs.read ignoreArchives) cacheFile;
   populateCacheFromArchiveRec Path.empty arch;
   Fpcache.finish ()
 
@@ -660,15 +669,6 @@
 (*                         Loading archives                              *)
 (*************************************************************************)
 
-let ignoreArchives =
-  Prefs.createBool "ignorearchives" false
-    "!ignore existing archive files"
-    ("When this preference is set, Unison will ignore any existing "
-     ^ "archive files and behave as though it were being run for the first "
-     ^ "time on these replicas.  It is "
-     ^ "not a good idea to set this option in a profile: it is intended for "
-     ^ "command-line use.")
-
 let setArchiveData thisRoot fspath (arch, hash, magic, properties) info =
   let archMode = archiveMode magic in
   let curMode = (Case.ops ())#modeDesc in
@@ -1547,12 +1547,12 @@
           currfspath path info archive
           archDesc archDig archStamp archRess scanInfo
     | (`FILE, _) ->
-        debug (fun() -> Util.msg "  buildUpdate -> Updated file\n");
+        debug (fun() -> Util.msg "  buildUpdate -> New file\n");
         None,
         begin
           showStatusAddLength scanInfo info;
           let (desc, dig, stamp, ress) =
-            Fpcache.fingerprint
+            Fpcache.fingerprint ~newfile:true
               scanInfo.fastCheck currfspath path info None in
           Xferhint.insertEntry currfspath path dig;
           Updates (File (desc, ContentsUpdated (dig, stamp, ress)),
@@ -1792,7 +1792,7 @@
   in
   let (cacheFilename, _) = archiveName fspath FPCache in
   let cacheFile = Os.fileInUnisonDir cacheFilename in
-  Fpcache.init scanInfo.fastCheck cacheFile;
+  Fpcache.init scanInfo.fastCheck (Prefs.read ignoreArchives) cacheFile;
   let (archive, updates) =
     Safelist.fold_right
       (fun path (arch, upd) ->
@@ -2203,10 +2203,11 @@
         (Format.sprintf "The properties of file %s have been modified\n"
            (Path.toString path))
   | Updates (File (desc, ContentsUpdated (_, _, ress)),
-             Previous (`FILE, oldDesc, _, oldRess)) ->
-      reportUpdate (fastCheckMiss path desc ress oldDesc oldRess)
-        (Format.sprintf "The contents of file %s has been modified\n"
-           (Path.toString path))
+             Previous (`FILE, oldDesc, oldFp, oldRess)) ->
+      if not (Os.isPseudoFingerprint oldFp) then
+        reportUpdate (fastCheckMiss path desc ress oldDesc oldRess)
+          (Format.sprintf "The contents of file %s have been modified\n"
+             (Path.toString path))
   | Updates (File (_, ContentsUpdated _), _) ->
       reportUpdate false
         (Format.sprintf "The file %s has been created\n"
@@ -2247,8 +2248,7 @@
   let scanInfo =
     { fastCheck = false; dirFastCheck = false;
       dirStamp = Props.changedDirStamp;
-      showStatus = false }
-  in
+      showStatus = false } in
   let (_, uiNew) = buildUpdateRec archive fspath localPath scanInfo in
   markPossiblyUpdatedRec fspath pathInArchive uiNew;
   explainUpdate pathInArchive uiNew;

Modified: trunk/src/xferhint.mli
===================================================================
--- trunk/src/xferhint.mli	2010-07-22 01:42:07 UTC (rev 458)
+++ trunk/src/xferhint.mli	2010-07-24 12:19:38 UTC (rev 459)
@@ -2,7 +2,7 @@
 (* Copyright 1999-2010, Benjamin C. Pierce (see COPYING for details) *)
 
 (* This module maintains a cache that can be used to map
-   an Os.fingerprint to a (Fspath.t * Path.t) naming a file that *may*
+   an Os.fullfingerprint to a (Fspath.t * Path.t) naming a file that *may*
    (if we are lucky) have this fingerprint.  The cache is not guaranteed
    to be reliable -- the things it returns are only hints, and must be
    double-checked before they are used (to optimize file transfers). *)



More information about the Unison-hackers mailing list