* Bumped version number: incompatible protocol changes

* Resume copy of partially transferred files. * Unicode mode is now the default when one of the hosts is under Windows or MacOS. This may make upgrades a bit more painful (the archives cannot be reused), but this is a much saner default. * Fastcheck is now the default under Windows. People mostly use NTFS nowadays and the Unicode API provides an equivalent to inode numbers for this filesystem. * Unison now fails if in unicode case-insensitive mode but the archive mode is not known (this means that we are upgrading from an older version which did not support this mode) * Changed the type of trivalued preferences (true/false/default) to an enumerated type * Removed the "reusewindows" preference, which was not used anymore. * GTK UI: do not reposition the file list on focus change
liyishuai · Jan 7, 2010 · a706515 · a706515
1 parent ae3e85d
commit a706515
Show file tree

Hide file tree

Showing 15 changed files with 181 additions and 101 deletions.
diff --git a/src/.depend b/src/.depend
@@ -13,7 +13,8 @@ files.cmi: uutil.cmi system.cmi props.cmi path.cmi lwt/lwt_util.cmi \
     lwt/lwt.cmi common.cmi 
 fileutil.cmi: 
 fingerprint.cmi: uutil.cmi path.cmi fspath.cmi 
-fpcache.cmi: 
+fpcache.cmi: system.cmi props.cmi path.cmi osx.cmi os.cmi fspath.cmi \
+    fileinfo.cmi 
 fs.cmi: system/system_intf.cmo fspath.cmi 
 fspath.cmi: system.cmi path.cmi name.cmi 
 globals.cmi: ubase/prefs.cmi pred.cmi path.cmi lwt/lwt.cmi common.cmi 
@@ -63,13 +64,13 @@ common.cmx: uutil.cmx ubase/util.cmx ubase/safelist.cmx props.cmx path.cmx \
 copy.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi transfer.cmi \
     ubase/trace.cmi ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi \
     path.cmi osx.cmi os.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi \
-    fspath.cmi fs.cmi fileinfo.cmi external.cmi common.cmi clroot.cmi \
-    bytearray.cmi abort.cmi copy.cmi 
+    fspath.cmi fs.cmi fpcache.cmi fingerprint.cmi fileinfo.cmi external.cmi \
+    common.cmi clroot.cmi bytearray.cmi abort.cmi copy.cmi 
 copy.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx transfer.cmx \
     ubase/trace.cmx ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx \
     path.cmx osx.cmx os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx \
-    fspath.cmx fs.cmx fileinfo.cmx external.cmx common.cmx clroot.cmx \
-    bytearray.cmx abort.cmx copy.cmi 
+    fspath.cmx fs.cmx fpcache.cmx fingerprint.cmx fileinfo.cmx external.cmx \
+    common.cmx clroot.cmx bytearray.cmx abort.cmx copy.cmi 
 external.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi lwt/lwt_util.cmi \
     lwt/lwt_unix.cmi lwt/lwt.cmi external.cmi 
 external.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx lwt/lwt_util.cmx \

diff --git a/src/RECENTNEWS b/src/RECENTNEWS
@@ -1,3 +1,23 @@
+CHANGES FROM VERSION 2.39.0
+
+* Bumped version number: incompatible protocol changes
+
+* Resume copy of partially transferred files.
+* Unicode mode is now the default when one of the hosts is under
+  Windows or MacOS.  This may make upgrades a bit more painful (the
+  archives cannot be reused), but this is a much saner default.
+* Fastcheck is now the default under Windows.  People mostly use NTFS
+  nowadays and the Unicode API provides an equivalent to inode numbers
+  for this filesystem.
+* Unison now fails if in unicode case-insensitive mode but the archive
+  mode is not known (this means that we are upgrading from an older
+  version which did not support this mode)
+* Changed the type of trivalued preferences (true/false/default) to an
+  enumerated type
+* Removed the "reusewindows" preference, which was not used anymore.
+* GTK UI: do not reposition the file list on focus change
+
+-------------------------------
 CHANGES FROM VERSION 2.38.5
 
 * Fix the fingerprint cache so that it works also with multiple paths

diff --git a/src/abort.ml b/src/abort.ml
@@ -25,7 +25,7 @@ let maxerrors =
     "This preference controls after how many errors Unison aborts a \
      directory transfer.  Setting it to a large number allows Unison \
      to transfer most of a directory even when some files fail to be \
-     copied.  The default is 1.  If the preference is set to high, \
+     copied.  The default is 1.  If the preference is set too high, \
      Unison may take a long time to abort in case of repeated \
      failures (for instance, when the disk is full)."
 

diff --git a/src/case.ml b/src/case.ml
@@ -51,10 +51,10 @@ let unicodeEncoding =
     "*Pseudo-preference for internal use only" ""
 
 (* Whether we default to Unicode encoding on OSX and Windows *)
-let defaultToUnicode = false
+let defaultToUnicode = true
 
 let useUnicode b =
-  let pref = Prefs.readBoolWithDefault unicode in
+  let pref = Prefs.read unicode in
   pref = `True ||
   (defaultToUnicode && pref = `Default && b)
 
@@ -66,8 +66,8 @@ let useUnicodeAPI () = useUnicode true
 (* server with the rest of the prefs.                                        *)
 let init b =
   Prefs.set someHostIsInsensitive
-    (Prefs.readBoolWithDefault caseInsensitiveMode = `True ||
-     (Prefs.readBoolWithDefault caseInsensitiveMode = `Default && b));
+    (Prefs.read caseInsensitiveMode = `True ||
+     (Prefs.read caseInsensitiveMode = `Default && b));
   Prefs.set unicodeEncoding (useUnicode b)
 
 (****)

diff --git a/src/case.mli b/src/case.mli
@@ -4,7 +4,7 @@
 val unicodeEncoding : bool Prefs.t
 val useUnicodeAPI : unit -> bool
 
-type mode
+type mode = Sensitive | Insensitive | UnicodeInsensitive
 
 val ops : unit ->
   < mode : mode; modeDesc : string;       (* Current mode *)

diff --git a/src/copy.ml b/src/copy.ml
@@ -117,6 +117,44 @@ let fileIsTransferred fspathTo pathTo desc fp ress =
    let fp' = Os.fingerprint fspathTo pathTo info in
    fp' = fp)
 
+(* We slice the files in 1GB chunks because that's the limit for
+   Fingerprint.subfile on 32 bit architectures *)
+let fingerprintLimit = Uutil.Filesize.ofInt64 1072693248L
+
+let rec fingerprintPrefix fspath path offset len accu =
+  if len = Uutil.Filesize.zero then accu else begin
+    let l = min len fingerprintLimit in
+    let fp = Fingerprint.subfile (Fspath.concat fspath path) offset l in
+    fingerprintPrefix fspath path
+      (Int64.add offset (Uutil.Filesize.toInt64 l)) (Uutil.Filesize.sub len l)
+      (fp :: accu)
+  end
+
+let fingerprintPrefixRemotely =
+  Remote.registerServerCmd
+    "fingerprintSubfile"
+    (fun _ (fspath, path, len) ->
+       Lwt.return (fingerprintPrefix fspath path 0L len []))
+
+let appendThreshold = Uutil.Filesize.ofInt (1024 * 1024)
+
+let validFilePrefix connFrom fspathFrom pathFrom fspathTo pathTo info desc =
+  let len = Props.length info.Fileinfo.desc in
+  if
+    info.Fileinfo.typ = `FILE &&
+    len >= appendThreshold && len < Props.length desc
+  then begin
+    Lwt.try_bind
+      (fun () ->
+         fingerprintPrefixRemotely connFrom (fspathFrom, pathFrom, len))
+      (fun fpFrom ->
+         let fpTo = fingerprintPrefix fspathTo pathTo 0L len [] in
+         Lwt.return (if fpFrom = fpTo then Some len else None))
+      (fun _ ->
+         Lwt.return None)
+  end else
+    Lwt.return None
+
 type transferStatus =
     Success of Fileinfo.t
   | Failure of string
@@ -163,8 +201,14 @@ let removeOldTempFile fspathTo pathTo =
 
 let openFileIn fspath path kind =
   match kind with
-    `DATA -> Fs.open_in_bin (Fspath.concat fspath path)
-  | `RESS -> Osx.openRessIn fspath path
+    `DATA ->
+      Fs.open_in_bin (Fspath.concat fspath path)
+  | `DATA_APPEND len ->
+      let ch = Fs.open_in_bin (Fspath.concat fspath path) in
+      LargeFile.seek_in ch (Uutil.Filesize.toInt64 len);
+      ch
+  | `RESS ->
+      Osx.openRessIn fspath path
 
 let openFileOut fspath path kind len =
   match kind with
@@ -189,6 +233,13 @@ let openFileOut fspath path kind len =
           in
           Unix.out_channel_of_descr fd
       end
+  | `DATA_APPEND len ->
+      let fullpath = Fspath.concat fspath path in
+      let perm = 0o600 in
+      let ch = Fs.open_out_gen [Open_wronly; Open_binary] perm fullpath in
+      Fs.chmod fullpath perm;
+      LargeFile.seek_out ch (Uutil.Filesize.toInt64 len);
+      ch
   | `RESS ->
       Osx.openRessOut fspath path len
 
@@ -336,6 +387,11 @@ let streamTransferInstruction =
     "processTransferInstruction" marshalTransferInstruction
     processTransferInstruction
 
+let showPrefixProgress id kind =
+  match kind with
+    `DATA_APPEND len -> Uutil.showProgress id len "r"
+  | _                -> ()
+
 let compress conn
      (biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id) =
   Lwt.catch
@@ -344,10 +400,11 @@ let compress conn
          (fun processTransferInstructionRemotely ->
             (* We abort the file transfer on error if it has not
                already started *)
-            if fileKind = `DATA then Abort.check id;
+            if fileKind <> `RESS then Abort.check id;
             let infd = openFileIn fspathFrom pathFrom fileKind in
             lwt_protect
               (fun () ->
+                 showPrefixProgress id fileKind;
                  let showProgress count =
                    Uutil.showProgress id (Uutil.Filesize.ofInt count) "r" in
                  let compr =
@@ -401,8 +458,9 @@ let destinationFd fspath path kind len outfd id =
     None    ->
       (* We abort the file transfer on error if it has not
          already started *)
-      if kind = `DATA then Abort.check id;
+      if kind <> `RESS then Abort.check id;
       let fd = openFileOut fspath path kind len in
+      showPrefixProgress id kind;
       outfd := Some fd;
       fd
   | Some fd ->
@@ -441,7 +499,7 @@ let transferFileContents
         Uutil.Filesize.zero
     | `Update (destFileDataSize, destFileRessSize) ->
         match fileKind with
-            `DATA -> destFileDataSize
+            `DATA | `DATA_APPEND _ -> destFileDataSize
           | `RESS -> destFileRessSize
   in
   let useRsync =
@@ -522,16 +580,27 @@ let transferRessourceForkAndSetFileinfo
 
 let reallyTransferFile
       connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
-      update desc fp ress id =
+      update desc fp ress id tempInfo =
   debug (fun() -> Util.msg "reallyTransferFile(%s,%s) -> (%s,%s,%s,%s)\n"
       (Fspath.toDebugString fspathFrom) (Path.toString pathFrom)
       (Fspath.toDebugString fspathTo) (Path.toString pathTo)
       (Path.toString realPathTo) (Props.toString desc));
-  removeOldTempFile fspathTo pathTo;
+  validFilePrefix connFrom fspathFrom pathFrom fspathTo pathTo tempInfo desc
+    >>= fun prefixLen ->
+  begin match prefixLen with
+    None ->
+      removeOldTempFile fspathTo pathTo
+  | Some len ->
+      debug
+        (fun() ->
+           Util.msg "Keeping %s bytes previously transferred for file %s\n"
+             (Uutil.Filesize.toString len) (Path.toString pathFrom))
+  end;
   (* Data fork *)
   transferFileContents
     connFrom fspathFrom pathFrom fspathTo pathTo realPathTo update
-    `DATA (Props.length desc) id >>= fun () ->
+    (match prefixLen with None -> `DATA | Some l -> `DATA_APPEND l)
+    (Props.length desc) id >>= fun () ->
   transferRessourceForkAndSetFileinfo
     connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
     update desc fp ress id
@@ -703,8 +772,8 @@ let transferFileUsingExternalCopyprog
     else
       Prefs.read copyprog
   in
-  let extraquotes = Prefs.readBoolWithDefault copyquoterem = `True
-                 || (  Prefs.readBoolWithDefault copyquoterem = `Default
+  let extraquotes = Prefs.read copyquoterem = `True
+                 || (  Prefs.read copyquoterem = `Default
                     && Util.findsubstring "rsync" prog <> None) in
   let addquotes root s =
     match root with
@@ -738,7 +807,8 @@ let transferFileUsingExternalCopyprog
 let transferFileLocal connFrom
       (fspathFrom, pathFrom, fspathTo, pathTo, realPathTo,
        update, desc, fp, ress, id) =
-  let (info, isTransferred) = fileIsTransferred fspathTo pathTo desc fp ress in
+  let (tempInfo, isTransferred) =
+    fileIsTransferred fspathTo pathTo desc fp ress in
   if isTransferred then begin
     (* File is already fully transferred (from some interrupted
        previous transfer). *)
@@ -752,7 +822,7 @@ let transferFileLocal connFrom
     Uutil.showProgress id len "alr";
     setFileinfo fspathTo pathTo realPathTo update desc;
     Xferhint.insertEntry fspathTo pathTo fp;
-    Lwt.return (`DONE (Success info, Some msg))
+    Lwt.return (`DONE (Success tempInfo, Some msg))
   end else
     registerFileTransfer pathTo fp
       (fun () ->
@@ -769,7 +839,7 @@ let transferFileLocal connFrom
              else begin
                reallyTransferFile
                  connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
-                 update desc fp ress id >>= fun status ->
+                 update desc fp ress id tempInfo >>= fun status ->
                Xferhint.insertEntry fspathTo pathTo fp;
                Lwt.return (`DONE (status, None))
              end)

diff --git a/src/fileinfo.ml b/src/fileinfo.ml
@@ -36,8 +36,8 @@ let symlinksAllowed =
 
 let init b =
   Prefs.set symlinksAllowed
-    (Prefs.readBoolWithDefault allowSymlinks = `True ||
-     (Prefs.readBoolWithDefault allowSymlinks = `Default && not b))
+    (Prefs.read allowSymlinks = `True ||
+     (Prefs.read allowSymlinks = `Default && not b))
 
 type typ = [ `ABSENT | `FILE | `DIRECTORY | `SYMLINK ]
 

diff --git a/src/mkProjectInfo.ml b/src/mkProjectInfo.ml
@@ -5,8 +5,8 @@
 
 let projectName = "unison"
 let majorVersion = 2
-let minorVersion = 38
-let pointVersionOrigin = 388 (* Revision that corresponds to point version 0 *)
+let minorVersion = 39
+let pointVersionOrigin = 396 (* Revision that corresponds to point version 0 *)
 
 (* Documentation:
    This is a program to construct a version of the form Major.Minor.Point,
@@ -65,7 +65,7 @@ let extract_str re str =
   Str.matched_group 1 str;;
 let extract_int re str = int_of_string (extract_str re str);;
 
-let revisionString = "$Rev: 393$";;
+let revisionString = "$Rev: 396$";;
 let pointVersion = if String.length revisionString > 5
 then Scanf.sscanf revisionString "$Rev: %d " (fun x -> x) - pointVersionOrigin
 else (* Determining the pointVersionOrigin in bzr is kind of tricky:
@@ -87,5 +87,3 @@ Printf.printf "MAJORVERSION=%d.%d\n" majorVersion minorVersion;;
 Printf.printf "VERSION=%d.%d.%d\n" majorVersion minorVersion pointVersion;;
 Printf.printf "NAME=%s\n" projectName;;
 
-
-
diff --git a/src/osx.ml b/src/osx.ml
@@ -45,8 +45,8 @@ let rsrc =
 
 let init b =
   Prefs.set rsrc
-    (Prefs.readBoolWithDefault rsrcSync = `True ||
-     (Prefs.readBoolWithDefault rsrcSync = `Default && b))
+    (Prefs.read rsrcSync = `True ||
+     (Prefs.read rsrcSync = `Default && b))
 
 (****)
 

diff --git a/src/ubase/prefs.ml b/src/ubase/prefs.ml
@@ -197,8 +197,7 @@ let createStringList name ?(local=false) doc fulldoc =
     (fun cell -> Uarg.String (fun s -> set cell (s::(fst !cell))))
 
 let createBoolWithDefault name ?(local=false) doc fulldoc =
-  createPrefInternal name `BOOLDEF local "default" doc fulldoc
-(*
+  createPrefInternal name `BOOLDEF local `Default doc fulldoc
     (fun v -> [match v with
                  `True    -> "true"
                | `False   -> "false"
@@ -213,14 +212,6 @@ let createBoolWithDefault name ?(local=false) doc fulldoc =
               | _                  -> `False
             in
             set cell v))
-*)
-    (fun v -> [v]) (fun cell -> Uarg.String (fun s -> set cell s))
-
-let readBoolWithDefault p =
-  match read p with
-    "yes" | "true"     -> `True
-  | "default" | "auto" -> `Default
-  | _                  -> `False
 
 (*****************************************************************************)
 (*                      Command-line parsing                                 *)

diff --git a/src/ubase/prefs.mli b/src/ubase/prefs.mli
@@ -4,8 +4,6 @@
 type 'a t
 
 val read : 'a t -> 'a
-(*FIX: remove this function and change the type of the preferences instead*)
-val readBoolWithDefault : string t -> [ `Default | `False | `True ]
 val set : 'a t -> 'a -> unit
 val name : 'a t -> string list
 
@@ -57,7 +55,7 @@ val createBoolWithDefault :
      -> ?local:bool             (* whether it is local to the client *)
      -> string              (* documentation string *)
      -> string              (* full (tex) documentation string *)
-     -> string t
+     -> [`True|`False|`Default] t
                             (*   -> new preference value *)
 
 exception IllegalValue of string

diff --git a/src/uicommon.ml b/src/uicommon.ml
@@ -55,19 +55,6 @@ let mainWindowHeight =
     ("Used to set the height (in lines) of the main window in the graphical "
      ^ "user interface.")
 
-(*FIX: remove this option... *)
-let reuseToplevelWindows =
-  Prefs.createBool "reusewindows" false
-    "*reuse top-level windows instead of making new ones" ""
-(* Not sure if this should actually be made available to users...
-    ("When true, causes the graphical interface to re-use top-level windows "
-     ^ "(e.g., the small window that says ``Connecting...'') rather than "
-     ^ "destroying them and creating fresh ones.  ") 
-*)
-(* For convenience: *)
-let _ = Prefs.alias reuseToplevelWindows "rw"
-
-
 let expert =
   Prefs.createBool "expert" false
     "*Enable some developers-only functionality in the UI" ""