[Unison-hackers] [unison-svn] r373 - in trunk/src: . ubase
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Wed Jul 15 11:01:32 EDT 2009
Author: vouillon
Date: 2009-07-15 11:01:31 -0400 (Wed, 15 Jul 2009)
New Revision: 373
Added:
trunk/src/ubase/proplist.ml
trunk/src/ubase/proplist.mli
Modified:
trunk/src/.depend
trunk/src/BUGS.txt
trunk/src/Makefile.OCaml
trunk/src/RECENTNEWS
trunk/src/TODO.txt
trunk/src/case.ml
trunk/src/case.mli
trunk/src/common.ml
trunk/src/files.ml
trunk/src/globals.ml
trunk/src/globals.mli
trunk/src/mkProjectInfo.ml
trunk/src/name.ml
trunk/src/name.mli
trunk/src/path.ml
trunk/src/path.mli
trunk/src/uigtk2.ml
trunk/src/uimacbridgenew.ml
trunk/src/update.ml
Log:
* GTK UI: disabled scrolling to the first unfinished item during transport.
It goes way too fast when lot of small files are synchronized, and it
makes it impossible to browse the file list during transport.
* Fixed computation of the amount of data to transfer: property updates
should count for zero.
* Mac GUI: use Unicode.protect to ensure that all string displayed are
encoded in UTF-8.
* In Unicode case-insensitive mode, use filenames in NFC normal form
when tranferring files
* Added a property list at the end of the archive file. This is a
better way to extend the format than the hack currently used to
store the case-sensitivity mode.
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/.depend 2009-07-15 15:01:31 UTC (rev 373)
@@ -244,15 +244,17 @@
path.cmx os.cmx main.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
globals.cmx fspath.cmx files.cmx common.cmx clroot.cmx
uimacbridgenew.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi \
- uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi system.cmi \
- stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi \
- path.cmi os.cmi main.cmo lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
- globals.cmi fspath.cmi files.cmi common.cmi clroot.cmi
+ unicode.cmi uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi \
+ system.cmi stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi \
+ ubase/prefs.cmi path.cmi os.cmi main.cmo lwt/lwt_util.cmi \
+ lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi files.cmi common.cmi \
+ clroot.cmi
uimacbridgenew.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx \
- uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx system.cmx \
- stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx \
- path.cmx os.cmx main.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
- globals.cmx fspath.cmx files.cmx common.cmx clroot.cmx
+ unicode.cmx uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx \
+ system.cmx stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx \
+ ubase/prefs.cmx path.cmx os.cmx main.cmx lwt/lwt_util.cmx \
+ lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx files.cmx common.cmx \
+ clroot.cmx
uitext.cmo: uutil.cmi ubase/util.cmi update.cmi uicommon.cmi transport.cmi \
ubase/trace.cmi system.cmi ubase/safelist.cmi remote.cmi recon.cmi \
ubase/prefs.cmi path.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
@@ -267,14 +269,16 @@
unicode_tables.cmx:
update.cmo: xferhint.cmi uutil.cmi ubase/util.cmi tree.cmi ubase/trace.cmi \
system.cmi stasher.cmi ubase/safelist.cmi remote.cmi props.cmi \
- ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi name.cmi ubase/myMap.cmi \
- lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi globals.cmi fspath.cmi fs.cmi \
- fingerprint.cmi fileinfo.cmi common.cmi case.cmi update.cmi
+ ubase/proplist.cmi ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi \
+ name.cmi ubase/myMap.cmi lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi \
+ globals.cmi fspath.cmi fs.cmi fingerprint.cmi fileinfo.cmi copy.cmi \
+ common.cmi case.cmi update.cmi
update.cmx: xferhint.cmx uutil.cmx ubase/util.cmx tree.cmx ubase/trace.cmx \
system.cmx stasher.cmx ubase/safelist.cmx remote.cmx props.cmx \
- ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx name.cmx ubase/myMap.cmx \
- lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx globals.cmx fspath.cmx fs.cmx \
- fingerprint.cmx fileinfo.cmx common.cmx case.cmx update.cmi
+ ubase/proplist.cmx ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx \
+ name.cmx ubase/myMap.cmx lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx \
+ globals.cmx fspath.cmx fs.cmx fingerprint.cmx fileinfo.cmx copy.cmx \
+ common.cmx case.cmx update.cmi
uutil.cmo: ubase/util.cmi ubase/trace.cmi ubase/projectInfo.cmo uutil.cmi
uutil.cmx: ubase/util.cmx ubase/trace.cmx ubase/projectInfo.cmx uutil.cmi
xferhint.cmo: ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi path.cmi os.cmi \
@@ -303,6 +307,8 @@
ubase/prefs.cmi
ubase/projectInfo.cmo:
ubase/projectInfo.cmx:
+ubase/proplist.cmo: ubase/util.cmi ubase/proplist.cmi
+ubase/proplist.cmx: ubase/util.cmx ubase/proplist.cmi
ubase/rx.cmo: ubase/rx.cmi
ubase/rx.cmx: ubase/rx.cmi
ubase/safelist.cmo: ubase/safelist.cmi
@@ -325,6 +331,7 @@
lwt/pqueue.cmi:
ubase/myMap.cmi:
ubase/prefs.cmi: ubase/util.cmi system.cmi
+ubase/proplist.cmi:
ubase/rx.cmi:
ubase/safelist.cmi:
ubase/trace.cmi: ubase/prefs.cmi
Modified: trunk/src/BUGS.txt
===================================================================
--- trunk/src/BUGS.txt 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/BUGS.txt 2009-07-15 15:01:31 UTC (rev 373)
@@ -137,13 +137,3 @@
Interactively adding an ignore pattern for src will not make
src/RECENTNEWS immediately disappear (as it does not directly match
the pattern)...
-
-[Mar 2002] When transferring by copying, copies on the remote side are
- not taken into account by the progress meter.
-
-progress bar calculation is not quite right -- e.g. dir sizes are not
- always accurate?
- [One needs to consider simultaneously the archive and the update to
- compute the size a directory (consider a directory with some
- updates deep inside]
- [also, Diff has an effect on the progress bar!]
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/Makefile.OCaml 2009-07-15 15:01:31 UTC (rev 373)
@@ -198,7 +198,7 @@
\
ubase/projectInfo.cmo ubase/myMap.cmo ubase/safelist.cmo \
ubase/uprintf.cmo ubase/util.cmo ubase/uarg.cmo \
- ubase/prefs.cmo ubase/trace.cmo \
+ ubase/prefs.cmo ubase/trace.cmo ubase/proplist.cmo \
\
lwt/pqueue.cmo lwt/lwt.cmo lwt/lwt_util.cmo lwt/lwt_unix.cmo \
\
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/RECENTNEWS 2009-07-15 15:01:31 UTC (rev 373)
@@ -1,5 +1,21 @@
CHANGES FROM VERSION 2.36.-27
+* GTK UI: disabled scrolling to the first unfinished item during transport.
+ It goes way too fast when lot of small files are synchronized, and it
+ makes it impossible to browse the file list during transport.
+* Fixed computation of the amount of data to transfer: property updates
+ should count for zero.
+* Mac GUI: use Unicode.protect to ensure that all string displayed are
+ encoded in UTF-8.
+* In Unicode case-insensitive mode, use filenames in NFC normal form
+ when tranferring files
+* Added a property list at the end of the archive file. This is a
+ better way to extend the format than the hack currently used to
+ store the case-sensitivity mode.
+
+-------------------------------
+CHANGES FROM VERSION 2.36.-27
+
* When a file transfer fails, turn off fastcheck for this file on the
next sync.
* Limit the number of simultaneous transfer using rsync
Modified: trunk/src/TODO.txt
===================================================================
--- trunk/src/TODO.txt 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/TODO.txt 2009-07-15 15:01:31 UTC (rev 373)
@@ -44,8 +44,6 @@
* Rsync debugging
- - R can't run with debugging (even in 2.13) -- Alan cannot reproduce
-
- when using socket mode under windows, upon completion of the first
external rsync call, the connection to the server is dropped (the
server gets an EOF and closes the connection; the client sees a
@@ -232,13 +230,7 @@
to respond to the prompts in the textual ui. is that explained
somewhere? a few typos i noticed: "with t fast", "nison", "off of".
-** what happens when we ssh through loopback and sync the same
- directory?
- ===> Needs to be thought about. In particular, what is the name of the
- archive in this case? Could they ever be exactly the same?
- ===> Try it and see.
-
* SMALL FUNCTIONALITY IMPROVEMENTS
* ================================
@@ -246,10 +238,6 @@
root = ~/bla
instead of requiring me to give an absolute path to my home dir.
-**** The archive should indicate whether it is case-dependant or not.
- (This is important for correctness -- if the case-insensitive flag is
- set differently on different runs, things can get very confused!)
-
*** [Marcus Sundman, 2008] Unison can't propagate changes in read-only
folders. The correct way to do it is to temporarily add write
permissions for the user to the folder, then do the changes and then
@@ -342,17 +330,6 @@
tolerate it, but the window could be eliminated entirely by allowing socket
connections to require a nonce.
-** Would be nice to transfer directories "incrementally" rather than
- atomically (i.e., if Unison is interrupted during the transfer of a
- directory, the partially-transferred directory should persist). Is
- this allowed by the specification? (If so, then it should just become
- the default behavior.)
- ===> BCP and William Lovas have discussed how to do this, but it is
- not all that straightforward.
-
-** we should reload the current preference file (if it's changed, at least)
- when we restart
-
** An idea for the interface to the external merge functionality:
created a general mechanism for invoking external functionality...
- in profile, declare a command of the form
@@ -450,6 +427,7 @@
time=true, you get a zillion conflicts...
==> This is probably a good idea, but I'm a little scared of all the
messages we'd get from upgrading users
+ ==> Also, "make" can get confused when the 'time' option is set
* Maybe we should write debugging and tracing information to stdout
instead of stderr?
@@ -512,6 +490,7 @@
On one server (Saul), Unison seems to use HUGE amounts of memory (250Mb
resident), while on my laptop it's much less. WTF?
+ ==> Is that real memory or virtual memory?
[Ben Wong, Aug 2002] Why not make unison fall back to addversionno if it
would otherwise bomb out with an incorrect version number? That way I
@@ -602,12 +581,6 @@
to be transferred, and a warning signal (display in red or something)
if these exceed the current setting of maxdelete.
-Might be nice to provide an option that says "if you're propagating a
- newly created directory and something goes wrong with something inside
- it, just ignore the file that failed and keep going with the rest of
- the directory." [We probably don't want to continue in all cases (for
- instance, when the disk is full)]
-
Would be nice to be able to run unison in a special mode like this
unison -relocate //old-host1//path1 //old-host2//path2 \
//new-host1//path1 //new-host2//path2
@@ -816,7 +789,7 @@
[Perdita Stevens, Perdita.Stevens at dcs.ed.ac.uk, Mar 14 2002]
===> It's not trivial (involves some subtle stuff about our RPC
implementation and the single-thread nature of the GUI), but might
- not be impossible either.
+ not be impossible either.
"Quit" during synchronization should abort all current operations (so
that temporary files are deleted) before exiting.
Modified: trunk/src/case.ml
===================================================================
--- trunk/src/case.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/case.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -138,6 +138,7 @@
method normalizePattern s = s
method caseInsensitiveMatch = false
method normalizeMatchedString s = s
+ method normalizeFilename s = s
method badEncoding s = false
end
@@ -149,6 +150,7 @@
method normalizePattern s = s
method caseInsensitiveMatch = true
method normalizeMatchedString s = s
+ method normalizeFilename s = s
method badEncoding s = false
end
@@ -160,6 +162,7 @@
method normalizePattern p = Unicode.normalize p
method caseInsensitiveMatch = false
method normalizeMatchedString s = Unicode.normalize s
+ method normalizeFilename s = Unicode.compose s
method badEncoding s = not (Unicode.check_utf_8 s)
end
Modified: trunk/src/case.mli
===================================================================
--- trunk/src/case.mli 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/case.mli 2009-07-15 15:01:31 UTC (rev 373)
@@ -7,12 +7,21 @@
type mode
val ops : unit ->
- < mode : mode; modeDesc : string;
- compare : string -> string -> int;
- hash : string -> int;
- normalizePattern : string -> string;
- caseInsensitiveMatch : bool;
+ < mode : mode; modeDesc : string; (* Current mode *)
+ compare : string -> string -> int; (* Comparison function *)
+ hash : string -> int; (* Hash function compatible with
+ the comparison function *)
+ normalizePattern : string -> string; (* Normalize a pattern *)
+ caseInsensitiveMatch : bool; (* Whether pattern matching
+ should be done in a case
+ insensitive way *)
normalizeMatchedString : string -> string;
- badEncoding : string -> bool >
+ (* Put the string in some form
+ suitable for pattern matching *)
+ normalizeFilename : string -> string; (* Convert a filename into
+ its preferred form
+ (NFC for Unicode). *)
+ badEncoding : string -> bool > (* Test whether the string uses
+ the correct encoding *)
val init : bool -> unit
Modified: trunk/src/common.ml
===================================================================
--- trunk/src/common.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/common.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -168,7 +168,10 @@
let riLength ri =
match ri.replicas with
- Different {rc1 = rc1; rc2 = rc2; direction = dir} ->
+ Different {rc1 = {status= `Unchanged | `PropsChanged};
+ rc2 = {status= `Unchanged | `PropsChanged}} ->
+ Uutil.Filesize.zero (* No contents propagated *)
+ | Different {rc1 = rc1; rc2 = rc2; direction = dir} ->
begin match dir with
Replica1ToReplica2 -> rcLength rc1 rc2
| Replica2ToReplica1 -> rcLength rc2 rc1
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/files.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -396,6 +396,19 @@
(* Calculate target paths *)
setupTargetPaths rootTo pathTo
>>= fun (workingDir, realPathTo, tempPathTo, localPathTo) ->
+ (* When in Unicode case-insensitive mode, we want to create files
+ with NFC normal-form filenames. *)
+ let realPathTo =
+ match update with
+ `Update _ ->
+ realPathTo
+ | `Copy ->
+ match Path.deconstructRev realPathTo with
+ None ->
+ assert false
+ | Some (name, parentPath) ->
+ Path.child parentPath (Name.normalize name)
+ in
(* Calculate source path *)
Update.translatePath rootFrom pathFrom >>= fun localPathFrom ->
let errors = ref [] in
@@ -445,9 +458,10 @@
let childThreads =
Update.NameMap.mapi
(fun name child ->
+ let nameTo = Name.normalize name in
copyRec (Path.child pFrom name)
- (Path.child pTo name)
- (Path.child realPTo name)
+ (Path.child pTo nameTo)
+ (Path.child realPTo nameTo)
child)
children
in
Modified: trunk/src/globals.ml
===================================================================
--- trunk/src/globals.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/globals.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -228,7 +228,7 @@
let () = Prefs.alias confirmBigDeletes "confirmbigdeletes"
-let ignore =
+let ignorePred =
Pred.create "ignore"
("Including the preference \\texttt{-ignore \\ARG{pathspec}} causes Unison to "
^ "completely ignore paths that match \\ARG{pathspec} (as well as their "
@@ -238,7 +238,7 @@
^ "details on ignoring paths is found in"
^ " \\sectionref{ignore}{Ignoring Paths}.")
-let ignorenot =
+let ignorenotPred =
Pred.create "ignorenot"
("This preference overrides the preference \\texttt{ignore}.
It gives a list of patterns
@@ -260,12 +260,12 @@
let shouldIgnore p =
let p = Path.toString p in
- (Pred.test ignore p) && not (Pred.test ignorenot p)
+ (Pred.test ignorePred p) && not (Pred.test ignorenotPred p)
let addRegexpToIgnore re =
- let oldRE = Pred.extern ignore in
+ let oldRE = Pred.extern ignorePred in
let newRE = re::oldRE in
- Pred.intern ignore newRE
+ Pred.intern ignorePred newRE
let merge =
Pred.create "merge" ~advanced:true
Modified: trunk/src/globals.mli
===================================================================
--- trunk/src/globals.mli 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/globals.mli 2009-07-15 15:01:31 UTC (rev 373)
@@ -73,6 +73,8 @@
(* Predicates on paths *)
val shouldIgnore : 'a Path.path -> bool
val shouldMerge : 'a Path.path -> bool
+val ignorePred : Pred.t
+val ignorenotPred : Pred.t
(* Be careful calling this to add new patterns to be ignored: Its value does NOT persist
when a new profile is loaded, so it has to be called again whenever this happens. *)
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/mkProjectInfo.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -91,3 +91,4 @@
+
Modified: trunk/src/name.ml
===================================================================
--- trunk/src/name.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/name.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -39,6 +39,8 @@
let hash n = (Case.ops())#hash n
+let normalize n = (Case.ops())#normalizeFilename n
+
(****)
let badEncoding s = (Case.ops())#badEncoding s
Modified: trunk/src/name.mli
===================================================================
--- trunk/src/name.mli 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/name.mli 2009-07-15 15:01:31 UTC (rev 373)
@@ -10,5 +10,7 @@
val eq : t -> t -> bool
val hash : t -> int
+val normalize : t -> t
+
val badEncoding : t -> bool
val badFile : t -> bool
Modified: trunk/src/path.ml
===================================================================
--- trunk/src/path.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/path.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -194,7 +194,7 @@
let hash p = Hashtbl.hash p
(* Pref controlling whether symlinks are followed. *)
-let follow = Pred.create "follow"
+let followPred = Pred.create "follow"
("Including the preference \\texttt{-follow \\ARG{pathspec}} causes Unison to \
treat symbolic links matching \\ARG{pathspec} as `invisible' and \
behave as if the object pointed to by the link had appeared literally \
@@ -205,7 +205,7 @@
let followLink path =
(Util.osType = `Unix || Util.isCygwin)
- && Pred.test follow (toString path)
+ && Pred.test followPred (toString path)
let magic p = p
let magic' p = p
Modified: trunk/src/path.mli
===================================================================
--- trunk/src/path.mli 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/path.mli 2009-07-15 15:01:31 UTC (rev 373)
@@ -34,6 +34,7 @@
val hash : local -> int
val followLink : local -> bool
+val followPred : Pred.t
val magic : t -> local
val magic' : local -> t
Added: trunk/src/ubase/proplist.ml
===================================================================
--- trunk/src/ubase/proplist.ml (rev 0)
+++ trunk/src/ubase/proplist.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -0,0 +1,36 @@
+(* Unison file synchronizer: src/ubase/proplist.ml *)
+(* Copyright 1999-2009, Benjamin C. Pierce
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+type 'a key = string
+type t = Obj.t Util.StringMap.t
+
+let names = ref Util.StringSet.empty
+
+let register nm =
+ if (Util.StringSet.mem nm !names) then
+ raise (Util.Fatal
+ (Format.sprintf "Property lists: %s already registered!" nm));
+ names := Util.StringSet.add nm !names;
+ nm
+
+let empty = Util.StringMap.empty
+
+let mem = Util.StringMap.mem
+
+let find (k : 'a key) m : 'a = Obj.obj (Util.StringMap.find k m)
+
+let add (k : 'a key) (v : 'a) m = Util.StringMap.add k (Obj.repr v) m
Added: trunk/src/ubase/proplist.mli
===================================================================
--- trunk/src/ubase/proplist.mli (rev 0)
+++ trunk/src/ubase/proplist.mli 2009-07-15 15:01:31 UTC (rev 373)
@@ -0,0 +1,12 @@
+(* Unison file synchronizer: src/ubase/proplist.mli *)
+(* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *)
+
+type 'a key
+type t
+
+val register : string -> 'a key
+
+val empty : t
+val mem : 'a key -> t -> bool
+val find : 'a key -> t -> 'a
+val add : 'a key -> 'a -> t -> t
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/uigtk2.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -1429,6 +1429,7 @@
adj#set_value (min v (upper -. adj#page_size));
end in
+(*
let makeFirstUnfinishedVisible pRiInFocus =
let im = Array.length !theState in
let rec find i =
@@ -1438,6 +1439,7 @@
| _ -> find (i+1) in
find 0
in
+*)
let updateDetails () =
begin match !current with
@@ -1650,6 +1652,8 @@
let totalBytesToTransfer = ref Uutil.Filesize.zero in
let totalBytesTransferred = ref Uutil.Filesize.zero in
+ let t0 = ref 0. in
+ let t1 = ref 0. in
let lastFrac = ref 0. in
let displayGlobalProgress v =
if v = 0. || abs_float (v -. !lastFrac) > 1. then begin
@@ -1657,10 +1661,18 @@
progressBar#set_fraction (max 0. (min 1. (v /. 100.)))
end;
(*
- if v > 0.5 then
- progressBar#set_text (Util.percent2string v)
- else
- progressBar#set_text "";
+ let t = Unix.gettimeofday () in
+ if t -. !t1 >= 1. then begin
+ t1 := t;
+ let remTime =
+ if v <= 0. then ""
+ else if v >= 100. then "00:00 ETA"
+ else
+ let t = truncate ((!t1 -. !t0) *. (100. -. v) /. v +. 0.5) in
+ Format.sprintf "%02d:%02d ETA" (t / 60) (t mod 60)
+ in
+ progressBar#set_text remTime
+ end
*)
in
@@ -1677,6 +1689,7 @@
let initGlobalProgress b =
totalBytesToTransfer := b;
totalBytesTransferred := Uutil.Filesize.zero;
+ t0 := Unix.gettimeofday (); t1 := !t0;
displayGlobalProgress 0.
in
@@ -1963,11 +1976,16 @@
showProgress (Uutil.File.ofLine i) rem "done";
theSI.whatHappened <- Some (res, !textDetailed);
fastRedisplay i;
+(* JV (7/09): It does not seem that useful to me to scroll the display
+ to make the first unfinished item visible. The scrolling is way
+ too fast, and it makes it impossible to browse the list. *)
+(*
sync_action :=
Some
(fun () ->
makeFirstUnfinishedVisible pRiThisRound;
sync_action := None);
+*)
gtk_sync false;
return ())
| Some _ ->
@@ -2160,7 +2178,8 @@
item.bytesToTransfer <- len;
initGlobalProgress len;
Uicommon.showDiffs item.ri
- (fun title text -> messageBox ~title (transcode text))
+ (fun title text ->
+ messageBox ~title:(transcode title) (transcode text))
Trace.status (Uutil.File.ofLine i);
displayGlobalProgress 0.;
fastRedisplay i)
Modified: trunk/src/uimacbridgenew.ml
===================================================================
--- trunk/src/uimacbridgenew.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/uimacbridgenew.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -19,7 +19,7 @@
mutable statusMessage : string option };;
let theState = ref [| |];;
-let unisonDirectory() = System.fspathToPrintString Os.unisonDir
+let unisonDirectory() = System.fspathToString Os.unisonDir
;;
Callback.register "unisonDirectory" unisonDirectory;;
@@ -56,6 +56,7 @@
(* Defined in MyController.m, used to redisplay the table
when the status for a row changes *)
external displayStatus : string -> unit = "displayStatus";;
+let displayStatus s = displayStatus (Unicode.protect s);;
(*
Called to create callback threads which wait on the C side for callbacks.
@@ -345,12 +346,16 @@
Callback.register "unisonInit2" unisonInit2;;
let unisonRiToDetails ri =
- match ri.whatHappened with
- Some (Util.Failed s) -> (Path.toString ri.ri.path1) ^ "\n" ^ s
- | _ -> (Path.toString ri.ri.path1) ^ "\n" ^ (Uicommon.details2string ri.ri " ");;
+ Unicode.protect
+ (match ri.whatHappened with
+ Some (Util.Failed s) ->
+ Path.toString ri.ri.path1 ^ "\n" ^ s
+ | _ ->
+ Path.toString ri.ri.path1 ^ "\n" ^
+ Uicommon.details2string ri.ri " ");;
Callback.register "unisonRiToDetails" unisonRiToDetails;;
-let unisonRiToPath ri = Path.toString ri.ri.path1;;
+let unisonRiToPath ri = Unicode.protect (Path.toString ri.ri.path1);;
Callback.register "unisonRiToPath" unisonRiToPath;;
let rcToString rc =
@@ -372,6 +377,8 @@
Callback.register "unisonRiToRight" unisonRiToRight;;
let unisonRiToFileSize ri =
+ (*FIX: will not work with files and directory larger than 1 GiB on
+ 32bit machines! *)
Uutil.Filesize.toInt (riLength ri.ri);;
Callback.register "unisonRiToFileSize" unisonRiToFileSize;;
@@ -420,7 +427,7 @@
let unisonRiToProgress ri =
match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with
(None,None,_) -> ""
- | (Some s,None,_) -> s
+ | (Some s,None,_) -> Unicode.protect s
| (_,_,Different {direction = Conflict}) -> ""
| (_,_,Problem _) -> ""
| (_,Some Util.Succeeded,_) -> "done"
@@ -428,6 +435,8 @@
Callback.register "unisonRiToProgress" unisonRiToProgress;;
let unisonRiToBytesTransferred ri =
+ (*FIX: will not work when transferring more than 1 GiB on 32bit
+ machines! *)
Uutil.Filesize.toInt ri.bytesTransferred;;
Callback.register "unisonRiToBytesTransferred" unisonRiToBytesTransferred;;
@@ -436,6 +445,9 @@
(* Defined in MyController.m, used to show diffs *)
external displayDiff : string -> string -> unit = "displayDiff";;
external displayDiffErr : string -> unit = "displayDiffErr";;
+let displayDiff title text =
+ displayDiff (Unicode.protect title) (Unicode.protect text);;
+let displayDiffErr err = displayDiffErr (Unicode.protect err)
(* If only properties have changed, we can't diff or merge.
'Can't diff' is produced (uicommon.ml) if diff is attemped
@@ -648,10 +660,10 @@
| _ -> assert false (* BOGUS? *);;
let unisonFirstRootString() =
let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in
- replica1;;
+ Unicode.protect replica1;;
let unisonSecondRootString() =
let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in
- replica2;;
+ Unicode.protect replica2;;
Callback.register "unisonFirstRootString" unisonFirstRootString;;
Callback.register "unisonSecondRootString" unisonSecondRootString;;
@@ -698,5 +710,6 @@
| Unix.Unix_error(ue,s1,s2) ->
Printf.sprintf "Unix error(%s,%s,%s)" (Unix.error_message ue) s1 s2
| _ -> Printexc.to_string e;;
-Callback.register "unisonExnInfo" unisonExnInfo;;
+Callback.register "unisonExnInfo"
+ (fun e -> Unicode.protect (unisonExnInfo e));;
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-07-13 22:26:15 UTC (rev 372)
+++ trunk/src/update.ml 2009-07-15 15:01:31 UTC (rev 373)
@@ -45,6 +45,7 @@
for this file on the next sync. *)
(*FIX: consider changing the way case-sensitivity mode is stored in
the archive *)
+(*FIX: we should use only one Marshal.from_channel *)
let archiveFormat = 22
module NameMap = MyMap.Make (Name)
@@ -326,7 +327,7 @@
and roots (second line) match skip the third line (time stamp), and read
in the archive *)
let loadArchiveLocal fspath (thisRoot: string) :
- (archive * int * string) option =
+ (archive * int * string * Proplist.t) option =
debug (fun() ->
Util.msg "Loading archive from %s\n" (System.fspathToDebugString fspath));
Util.convertUnixErrorsToFatal "loading archive" (fun () ->
@@ -360,8 +361,15 @@
try
let ((archive, hash, magic) : archive * int * string) =
Marshal.from_channel c in
+ let properties =
+ try
+ ignore (input_char c); (* Marker *)
+ Marshal.from_channel c
+ with End_of_file ->
+ Proplist.empty
+ in
close_in c;
- Some (archive, hash, magic)
+ Some (archive, hash, magic, properties)
with Failure s -> raise (Util.Fatal (Printf.sprintf
"Archive file seems damaged (%s): \
throw away archives on both machines and try again" s))
@@ -372,7 +380,7 @@
None))
(* Inverse to loadArchiveLocal *)
-let storeArchiveLocal fspath thisRoot archive hash magic =
+let storeArchiveLocal fspath thisRoot archive hash magic properties =
debug (fun() ->
Util.msg "Saving archive in %s\n" (System.fspathToDebugString fspath));
Util.convertUnixErrorsToFatal "saving archive" (fun () ->
@@ -389,6 +397,9 @@
(Util.time2string (Util.time()))
((Case.ops())#modeDesc));
Marshal.to_channel c (archive, hash, magic) [Marshal.No_sharing];
+ output_char c '\000'; (* Marker that indicates that the archive
+ is followed by a property list *)
+ Marshal.to_channel c properties [Marshal.No_sharing];
close_out c)
(* Remove the archieve under the root path [fspath] with archiveVersion [v] *)
@@ -482,6 +493,17 @@
debug (fun () -> Printf.eprintf "Setting archive for %s\n" thisRoot);
Hashtbl.replace archiveCache thisRoot archive
+(* archiveCache: map(rootGlobalName, property list) *)
+let archivePropCache = Hashtbl.create 7
+
+(* Retrieve an archive property list from the cache *)
+let getArchiveProps (thisRoot: string): Proplist.t =
+ Hashtbl.find archivePropCache thisRoot
+
+(* Update the property list cache. *)
+let setArchivePropsLocal (thisRoot: string) (props: Proplist.t) =
+ Hashtbl.replace archivePropCache thisRoot props
+
let fileUnchanged oldInfo newInfo =
oldInfo.Fileinfo.typ = `FILE && newInfo.Fileinfo.typ = `FILE
&&
@@ -575,10 +597,11 @@
Lwt.return (Some (0, ""))
else begin
match loadArchiveLocal arcFspath thisRoot with
- Some (arch, hash, magic) ->
+ Some (arch, hash, magic, properties) ->
let info' = Fileinfo.get' arcFspath in
if fileUnchanged info info' then begin
setArchiveLocal thisRoot arch;
+ setArchivePropsLocal thisRoot properties;
Hashtbl.replace archiveInfoCache thisRoot info;
Lwt.return (Some (hash, magic))
end else
@@ -590,14 +613,16 @@
end
end else begin
match loadArchiveLocal arcFspath thisRoot with
- Some (arch, hash, magic) ->
+ Some (arch, hash, magic, properties) ->
setArchiveLocal thisRoot arch;
+ setArchivePropsLocal thisRoot properties;
let info = Fileinfo.get' arcFspath in
Hashtbl.replace archiveInfoCache thisRoot info;
Lwt.return (Some (hash, magic))
| None ->
(* No archive found *)
setArchiveLocal thisRoot NoArchive;
+ setArchivePropsLocal thisRoot Proplist.empty;
Hashtbl.remove archiveInfoCache thisRoot;
Lwt.return (Some (0, ""))
end)
@@ -1281,8 +1306,8 @@
Error
("Two or more files on a case-sensitive system have names \
identical except for case. They cannot be synchronized to a \
- case-insensitive file system. (" ^
- Path.toString path' ^ ")")
+ case-insensitive file system. (File '" ^
+ Path.toString path' ^ "')")
in
updates := (nm, uiChild) :: !updates;
archive
@@ -1495,6 +1520,32 @@
(ArchiveDir (desc, NameMap.add name' arch otherChildren),
updates)
+(* All the predicates that may change the set of files scanned during
+ update detection *)
+let updatePredicates =
+ [("immutable", immutable); ("immutablenot", immutablenot);
+ ("ignore", Globals.ignorePred); ("ignorenot", Globals.ignorenotPred);
+ ("follow", Path.followPred)]
+
+let predKey : (string * string list) list Proplist.key =
+ Proplist.register "update predicates"
+
+let checkNoUpdatePredicateChange thisRoot =
+ let props = getArchiveProps thisRoot in
+ let oldPreds = try Proplist.find predKey props with Not_found -> [] in
+ let newPreds =
+ List.map (fun (nm, p) -> (nm, Pred.extern p)) updatePredicates in
+(*
+List.iter
+ (fun (nm, l) ->
+ Format.eprintf "%s at ." nm;
+ List.iter (fun s -> Format.eprintf " %s at ." s) l)
+newPreds;
+Format.eprintf "==> %b at ." (oldPreds = newPreds);
+*)
+ setArchivePropsLocal thisRoot (Proplist.add predKey newPreds props);
+ oldPreds = newPreds
+
(* for the given path, find the archive and compute the list of update
items; as a side effect, update the local archive w.r.t. time-stamps for
unchanged files *)
@@ -1509,6 +1560,7 @@
deleted. --BCP 2006 *)
let (arcName,thisRoot) = archiveName fspath MainArch in
let archive = getArchive thisRoot in
+ let _ = checkNoUpdatePredicateChange thisRoot in
let (archive, updates) =
Safelist.fold_right
(fun path (arch, upd) ->
@@ -1590,8 +1642,9 @@
Format.print_flush();
**)
let archiveHash = checkArchive true [] archive 0 in
+ let props = getArchiveProps root in
storeArchiveLocal
- (Os.fileInUnisonDir newName) root archive archiveHash magic;
+ (Os.fileInUnisonDir newName) root archive archiveHash magic props;
Lwt.return (Some archiveHash)
let prepareCommitOnRoot
More information about the Unison-hackers
mailing list