[Unison-hackers] [unison-svn] r353 - in trunk/src: . ubase
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Sat Jun 13 05:28:04 EDT 2009
Author: vouillon
Date: 2009-06-13 05:28:01 -0400 (Sat, 13 Jun 2009)
New Revision: 353
Modified:
trunk/src/RECENTNEWS
trunk/src/copy.ml
trunk/src/files.ml
trunk/src/mkProjectInfo.ml
trunk/src/osx.ml
trunk/src/ubase/myMap.ml
trunk/src/ubase/myMap.mli
trunk/src/update.ml
Log:
* Fixed bug introduced during file transfer cleanup that could lead to
uncaught exceptions
* Simplified function validate in myMap.ml
* Mac OS: do not check filler contents in Apple Double files
(the spec says it should be all zeroes, but Mac OS sets it to
"Mac OS X "...)
* Use a hard link rather than a copy when possible for creating the
MainArch-files in Update.postCommitArchive
* Remove duplicate calls to Stasher.stashCurrentVersion in update.ml
(as well as now unnecessary calls to Update.updateArchive in files.ml)
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/RECENTNEWS 2009-06-13 09:28:01 UTC (rev 353)
@@ -1,5 +1,19 @@
CHANGES FROM VERSION 2.35.-17
+* Fixed bug introduced during file transfer cleanup that could lead to
+ uncaught exceptions
+* Simplified function validate in myMap.ml
+* Mac OS: do not check filler contents in Apple Double files
+ (the spec says it should be all zeroes, but Mac OS sets it to
+ "Mac OS X "...)
+* Use a hard link rather than a copy when possible for creating the
+ MainArch-files in Update.postCommitArchive
+* Remove duplicate calls to Stasher.stashCurrentVersion in update.ml
+ (as well as now unnecessary calls to Update.updateArchive in files.ml)
+
+-------------------------------
+CHANGES FROM VERSION 2.35.-17
+
* Fixed bug resulting in slow performances when transferring a file
using our rsync implementation from a 64-bit architecture to a
32-bit architecture.
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/copy.ml 2009-06-13 09:28:01 UTC (rev 353)
@@ -337,7 +337,7 @@
let compress conn
(biOpt, fspathFrom, pathFrom, fileKind, sizeFrom, id, file_id) =
- Util.convertUnixErrorsToTransient "rsync sender"
+ Lwt.catch
(fun () ->
streamTransferInstruction conn
(fun processTransferInstructionRemotely ->
@@ -362,6 +362,10 @@
Lwt.return ())
(fun () ->
close_in_noerr infd)))
+ (fun e ->
+ (* We cannot wrap the code above with the handler below,
+ as the code is executed asynchronously. *)
+ Util.convertUnixErrorsToTransient "rsync sender" (fun () -> raise e))
let compressRemotely = Remote.registerServerCmd "compress" compress
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/files.ml 2009-06-13 09:28:01 UTC (rev 353)
@@ -92,15 +92,12 @@
Update.transaction (fun id ->
Update.replaceArchive rootFrom pathFrom Update.NoArchive id
>>= (fun _ ->
- (* Unison do the next line cause we want to keep a backup of the file.
- FIX: We only need this when we are making backups *)
- Update.updateArchive rootTo pathTo ui id >>= (fun _ ->
- Update.replaceArchive rootTo pathTo Update.NoArchive id
+ Update.replaceArchive rootTo pathTo Update.NoArchive id
>>= (fun localPathTo ->
(* Make sure the target is unchanged *)
(* (There is an unavoidable race condition here.) *)
Update.checkNoUpdates rootTo pathTo ui >>= (fun () ->
- performDelete rootTo (None, localPathTo))))))
+ performDelete rootTo (None, localPathTo)))))
(* ------------------------------------------------------------ *)
@@ -450,12 +447,7 @@
corresponding to this path *)
Update.updateArchive rootFrom pathFrom uiFrom id
>>= fun (localPathFrom, archFrom) ->
- let make_backup = (* FIX: this call should probably be removed... *)
- (* Perform (asynchronously) a backup of the destination files *)
- Update.updateArchive rootTo pathTo uiTo id
- in
copyRec localPathFrom tempPathTo realPathTo archFrom >>= fun archTo ->
- make_backup >>= fun _ ->
Update.replaceArchive rootTo pathTo archTo id >>= fun _ ->
rename rootTo pathTo localPathTo workingDir tempPathTo realPathTo uiTo)
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/mkProjectInfo.ml 2009-06-13 09:28:01 UTC (rev 353)
@@ -161,3 +161,4 @@
+
Modified: trunk/src/osx.ml
===================================================================
--- trunk/src/osx.ml 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/osx.ml 2009-06-13 09:28:01 UTC (rev 353)
@@ -120,8 +120,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
Modified: trunk/src/ubase/myMap.ml
===================================================================
--- trunk/src/ubase/myMap.ml 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/ubase/myMap.ml 2009-06-13 09:28:01 UTC (rev 353)
@@ -39,7 +39,7 @@
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
- val validate: 'a t -> [`Ok | `Duplicate of key | `Invalid]
+ val validate: 'a t -> [`Ok | `Duplicate of key | `Invalid of key * key]
end
module Make(Ord: OrderedType) = struct
@@ -227,43 +227,26 @@
let rec validate_both v m v' =
match m with
Empty ->
- `Ok
+ let c = Ord.compare v v' in
+ if c < 0 then `Ok
+ else if c = 0 then `Duplicate v
+ else `Invalid (v, v')
| Node (l, v'', _, r, _) ->
- val_combine
- (val_combine
- (let c = Ord.compare v'' v' in
- if c < 0 then `Ok
- else if c = 0 then `Duplicate v''
- else `Invalid)
- (let c = Ord.compare v v'' in
- if c < 0 then `Ok
- else if c = 0 then `Duplicate v''
- else `Invalid))
- (val_combine (validate_both v l v'') (validate_both v'' r v'))
+ val_combine (validate_both v l v'') (validate_both v'' r v')
let rec validate_left m v =
match m with
Empty ->
`Ok
| Node (l, v', _, r, _) ->
- val_combine
- (let c = Ord.compare v' v in
- if c < 0 then `Ok
- else if c = 0 then `Duplicate v'
- else `Invalid)
- (val_combine (validate_left l v') (validate_both v' r v))
+ val_combine (validate_left l v') (validate_both v' r v)
let rec validate_right v m =
match m with
Empty ->
`Ok
| Node (l, v', _, r, _) ->
- val_combine
- (let c = Ord.compare v v' in
- if c < 0 then `Ok
- else if c = 0 then `Duplicate v'
- else `Invalid)
- (val_combine (validate_both v l v') (validate_right v' r))
+ val_combine (validate_both v l v') (validate_right v' r)
let validate m =
match m with
Modified: trunk/src/ubase/myMap.mli
===================================================================
--- trunk/src/ubase/myMap.mli 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/ubase/myMap.mli 2009-06-13 09:28:01 UTC (rev 353)
@@ -113,11 +113,10 @@
equal data. [cmp] is the equality predicate used to compare
the data associated with the keys. *)
- val validate: 'a t -> [`Ok | `Duplicate of key | `Invalid]
+ val validate: 'a t -> [`Ok | `Duplicate of key | `Invalid of key * key]
end
(** Output signature of the functor {!Map.Make}. *)
module Make (Ord : OrderedType) : S with type key = Ord.t
(** Functor building an implementation of the map structure
given a totally ordered type. *)
-
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-06-10 08:22:52 UTC (rev 352)
+++ trunk/src/update.ml 2009-06-13 09:28:01 UTC (rev 353)
@@ -225,11 +225,12 @@
"Corrupted archive: \
the file %s occurs twice in path %s"
(Name.toString nm) (Path.toString path)));
- | `Invalid ->
+ | `Invalid (nm, nm') ->
raise
(Util.Fatal (Printf.sprintf
- "Corrupted archive: the files are not \
+ "Corrupted archive: the files %s and %s are not \
correctely ordered in directory %s"
+ (Name.toString nm) (Name.toString nm')
(Path.toString path)));
end;
NameMap.fold
@@ -389,7 +390,8 @@
debug (fun() ->
Util.msg "Removing archive %s\n" (System.fspathToDebugString fspath));
Util.convertUnixErrorsToFatal "removing archive" (fun () ->
- if System.file_exists fspath then System.unlink fspath))
+ try System.unlink fspath
+ with Unix.Unix_error (Unix.ENOENT, _, _) -> ()))
(* [removeArchiveOnRoot root v] invokes [removeArchive fspath v] on the
server, where [fspath] is the path to root on the server *)
@@ -429,14 +431,19 @@
(System.fspathToDebugString ffrom)
(System.fspathToDebugString fto));
Util.convertUnixErrorsToFatal "copying archive" (fun () ->
- let outFd =
- System.open_out_gen
- [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 fto in
- System.chmod fto 0o600; (* In case the file already existed *)
- let inFd = System.open_in_bin ffrom in
- Uutil.readWrite inFd outFd (fun _ -> ());
- close_in inFd;
- close_out outFd;
+ System.unlink fto;
+ begin try
+ System.link ffrom fto
+ with Unix.Unix_error _ ->
+ let outFd =
+ System.open_out_gen
+ [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 fto in
+ System.chmod fto 0o600; (* In case the file already existed *)
+ let inFd = System.open_in_bin ffrom in
+ Uutil.readWrite inFd outFd (fun _ -> ());
+ close_in inFd;
+ close_out outFd
+ end;
let arcFspath = Os.fileInUnisonDir toname in
let info = Fileinfo.get' arcFspath in
Hashtbl.replace archiveInfoCache thisRoot info))
@@ -1775,7 +1782,6 @@
let (localPath, subArch) = getPathInArchive archive Path.empty path in
let newArch = updateArchiveRec ui (stripArchive path subArch) in
let commit () =
- let _ = Stasher.stashCurrentVersion fspath localPath None in
let archive = getArchive root in
let archive, () =
updatePathInArchive archive fspath Path.empty path
More information about the Unison-hackers
mailing list