[Unison-hackers] [unison-svn] r356 - in branches/2.27/src: . lwt
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Thu Jun 18 04:34:27 EDT 2009
Author: vouillon
Date: 2009-06-18 04:34:23 -0400 (Thu, 18 Jun 2009)
New Revision: 356
Modified:
branches/2.27/src/RECENTNEWS
branches/2.27/src/lwt/depend
branches/2.27/src/lwt/lwt_unix.ml
branches/2.27/src/mkProjectInfo.ml
branches/2.27/src/os.ml
branches/2.27/src/osx.ml
branches/2.27/src/transfer.ml
Log:
Backport to stable release:
* Fixed bug resulting in slow performances when transferring a file
using our rsync implementation from a 64-bit architecture to a
32-bit architecture.
* Fixed bug in Lwt_unix.run which could make it fail with a Not_found
exception (see [Not_found raised in tryCopyMovedFile] errors)
* Properly deals with non-conformant AppleDouble files produced
by Mac OS X.
* Fixed bug that results in Unison missing ressource fork changes
Modified: branches/2.27/src/RECENTNEWS
===================================================================
--- branches/2.27/src/RECENTNEWS 2009-06-17 14:42:07 UTC (rev 355)
+++ branches/2.27/src/RECENTNEWS 2009-06-18 08:34:23 UTC (rev 356)
@@ -1,3 +1,16 @@
+CHANGES FROM VERSION 2.27.140
+
+Backport to stable release:
+* Fixed bug resulting in slow performances when transferring a file
+ using our rsync implementation from a 64-bit architecture to a
+ 32-bit architecture.
+* Fixed bug in Lwt_unix.run which could make it fail with a Not_found
+ exception (see [Not_found raised in tryCopyMovedFile] errors)
+* Properly deals with non-conformant AppleDouble files produced
+ by Mac OS X.
+* Fixed bug that results in Unison missing ressource fork changes
+
+-------------------------------
CHANGES FROM VERSION 2.27.109
Backport to stable release:
Modified: branches/2.27/src/lwt/depend
===================================================================
--- branches/2.27/src/lwt/depend 2009-06-17 14:42:07 UTC (rev 355)
+++ branches/2.27/src/lwt/depend 2009-06-18 08:34:23 UTC (rev 356)
@@ -6,5 +6,7 @@
lwt_util.cmx: lwt.cmx lwt_util.cmi
pqueue.cmo: pqueue.cmi
pqueue.cmx: pqueue.cmi
+lwt.cmi:
lwt_unix.cmi: lwt.cmi
lwt_util.cmi: lwt.cmi
+pqueue.cmi:
Modified: branches/2.27/src/lwt/lwt_unix.ml
===================================================================
--- branches/2.27/src/lwt/lwt_unix.ml 2009-06-17 14:42:07 UTC (rev 355)
+++ branches/2.27/src/lwt/lwt_unix.ml 2009-06-18 08:34:23 UTC (rev 356)
@@ -141,33 +141,39 @@
restart_threads !event_counter now;
List.iter
(fun fd ->
- match List.assoc fd !inputs with
- `Read (buf, pos, len, res) ->
- wrap_syscall inputs fd res
- (fun () -> Unix.read fd buf pos len)
- | `Accept res ->
- wrap_syscall inputs fd res
- (fun () ->
- let (s, _) as v = Unix.accept fd in
- if not windows_hack then Unix.set_nonblock s;
- v)
- | `Wait res ->
- wrap_syscall inputs fd res (fun () -> ()))
+ try
+ match List.assoc fd !inputs with
+ `Read (buf, pos, len, res) ->
+ wrap_syscall inputs fd res
+ (fun () -> Unix.read fd buf pos len)
+ | `Accept res ->
+ wrap_syscall inputs fd res
+ (fun () ->
+ let (s, _) as v = Unix.accept fd in
+ if not windows_hack then Unix.set_nonblock s;
+ v)
+ | `Wait res ->
+ wrap_syscall inputs fd res (fun () -> ())
+ with Not_found ->
+ ())
readers;
List.iter
(fun fd ->
- match List.assoc fd !outputs with
- `Write (buf, pos, len, res) ->
- wrap_syscall outputs fd res
- (fun () -> Unix.write fd buf pos len)
- | `CheckSocket res ->
- wrap_syscall outputs fd res
- (fun () ->
- try ignore (Unix.getpeername fd) with
- Unix.Unix_error (Unix.ENOTCONN, _, _) ->
- ignore (Unix.read fd " " 0 1))
- | `Wait res ->
- wrap_syscall inputs fd res (fun () -> ()))
+ try
+ match List.assoc fd !outputs with
+ `Write (buf, pos, len, res) ->
+ wrap_syscall outputs fd res
+ (fun () -> Unix.write fd buf pos len)
+ | `CheckSocket res ->
+ wrap_syscall outputs fd res
+ (fun () ->
+ try ignore (Unix.getpeername fd) with
+ Unix.Unix_error (Unix.ENOTCONN, _, _) ->
+ ignore (Unix.read fd " " 0 1))
+ | `Wait res ->
+ wrap_syscall inputs fd res (fun () -> ())
+ with Not_found ->
+ ())
writers;
if !child_exited then begin
child_exited := false;
Modified: branches/2.27/src/mkProjectInfo.ml
===================================================================
--- branches/2.27/src/mkProjectInfo.ml 2009-06-17 14:42:07 UTC (rev 355)
+++ branches/2.27/src/mkProjectInfo.ml 2009-06-18 08:34:23 UTC (rev 356)
@@ -79,3 +79,4 @@
+
Modified: branches/2.27/src/os.ml
===================================================================
--- branches/2.27/src/os.ml 2009-06-17 14:42:07 UTC (rev 355)
+++ branches/2.27/src/os.ml 2009-06-18 08:34:23 UTC (rev 356)
@@ -237,7 +237,7 @@
in
retryLoop 10 info (* Maximum retries: 10 times *)
(match optDig with None -> None | Some (d, _) -> Some d)
- (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)
Modified: branches/2.27/src/osx.ml
===================================================================
--- branches/2.27/src/osx.ml 2009-06-17 14:42:07 UTC (rev 355)
+++ branches/2.27/src/osx.ml 2009-06-18 08:34:23 UTC (rev 356)
@@ -53,6 +53,7 @@
let doubleFiller = String.make 16 '\000'
let finfoLength = 32L
let emptyFinderInfo () = String.make 32 '\000'
+let ressource_fork_empty_tag = "This resource fork intentionally left blank "
let getInt2 buf ofs = (Char.code buf.[ofs]) * 256 + Char.code buf.[ofs + 1]
@@ -118,8 +119,6 @@
fail path "bad magic number";
if String.sub header 4 4 <> doubleVersion then
fail path "bad version";
- if String.sub header 8 16 <> doubleFiller then
- fail path "bad filler";
let numEntries = getInt2 header 24 in
let entries = ref [] in
for i = 1 to numEntries do
@@ -213,21 +212,36 @@
let (fspath, path) = Fspath.findWorkingDir fspath path in
let (doublePath, inch, entries) = openDouble fspath path in
let (rsrcOffset, rsrcLength) =
- try Safelist.assoc `RSRC entries with Not_found ->
- (0L, 0L)
+ try
+ let (offset, len) = Safelist.assoc `RSRC entries in
+ (* We need to check that the ressource fork is not a
+ dummy one included for compatibility reasons *)
+ if len = 286L &&
+ protect (fun () ->
+ LargeFile.seek_in inch (Int64.add offset 16L);
+ let len = String.length ressource_fork_empty_tag in
+ let buf = String.create len in
+ really_input inch buf 0 len;
+ buf = ressource_fork_empty_tag)
+ (fun () -> close_in_noerr inch)
+ then
+ (0L, 0L)
+ else
+ (offset, len)
+ with Not_found ->
+ (0L, 0L)
in
let finfo =
protect (fun () ->
try
let (ofs, len) = Safelist.assoc `FINFO entries in
- if len <> finfoLength then fail doublePath "bad finder info";
- let res = readDoubleFromOffset doublePath inch ofs 32 in
- close_in inch;
- res
+ if len < finfoLength then fail doublePath "bad finder info";
+ readDoubleFromOffset doublePath inch ofs 32
with Not_found ->
"")
(fun () -> close_in_noerr inch)
in
+ close_in inch;
let stats = Unix.LargeFile.stat doublePath in
{ ressInfo =
if rsrcLength = 0L then NoRess else
@@ -283,7 +297,7 @@
let (doublePath, inch, entries) = openDouble fspath path in
begin try
let (ofs, len) = Safelist.assoc `FINFO entries in
- if len <> finfoLength then fail doublePath "bad finder info";
+ if len < finfoLength then fail doublePath "bad finder info";
let fullFinfo =
protect
(fun () ->
Modified: branches/2.27/src/transfer.ml
===================================================================
--- branches/2.27/src/transfer.ml 2009-06-17 14:42:07 UTC (rev 355)
+++ branches/2.27/src/transfer.ml 2009-06-18 08:34:23 UTC (rev 356)
@@ -451,6 +451,10 @@
| [], r :: r' ->
addList k r r'
| ((cs, fp) :: r), _ ->
+ (* Negative 31-bits integers are sign-extended when
+ unmarshalled on a 64-bit architecture, so we
+ truncate them back to 31 bits. *)
+ let cs = cs land 0x7fffffff in
let h = (hash cs) land (hashTableLength - 1) in
hashTable.(h) <- (k, cs, fp)::(hashTable.(h));
addList (k + 1) r l'
More information about the Unison-hackers
mailing list