[Unison-hackers] [unison-svn] r354 - in trunk/src: . system
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Mon Jun 15 10:26:06 EDT 2009
Author: vouillon
Date: 2009-06-15 10:26:01 -0400 (Mon, 15 Jun 2009)
New Revision: 354
Modified:
trunk/src/RECENTNEWS
trunk/src/mkProjectInfo.ml
trunk/src/os.ml
trunk/src/osx.ml
trunk/src/system/system_win.ml
trunk/src/system/system_win_stubs.c
trunk/src/unicode.ml
Log:
* Properly deals with non-conformant AppleDouble files produced by Mac
OS X; for compatibility, produce AppleDouble files with the same
structure as the one produced by Mac OS X.
* Fixed a bug that resulted in Unison missing ressource fork changes
* Windows Unicode API: use hard links when available when commiting
the archive to disk
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-06-13 09:28:01 UTC (rev 353)
+++ trunk/src/RECENTNEWS 2009-06-15 14:26:01 UTC (rev 354)
@@ -1,5 +1,15 @@
CHANGES FROM VERSION 2.35.-17
+* Properly deals with non-conformant AppleDouble files produced by Mac
+ OS X; for compatibility, produce AppleDouble files with the same
+ structure as the one produced by Mac OS X.
+* Fixed a bug that resulted in Unison missing ressource fork changes
+* Windows Unicode API: use hard links when available when commiting
+ the archive to disk
+
+-------------------------------
+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
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-06-13 09:28:01 UTC (rev 353)
+++ trunk/src/mkProjectInfo.ml 2009-06-15 14:26:01 UTC (rev 354)
@@ -162,3 +162,4 @@
+
Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml 2009-06-13 09:28:01 UTC (rev 353)
+++ trunk/src/os.ml 2009-06-15 14:26:01 UTC (rev 354)
@@ -266,7 +266,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: trunk/src/osx.ml
===================================================================
--- trunk/src/osx.ml 2009-06-13 09:28:01 UTC (rev 353)
+++ trunk/src/osx.ml 2009-06-15 14:26:01 UTC (rev 354)
@@ -15,7 +15,10 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
+let debug = Trace.debug "osx"
+(****)
+
external isMacOSXPred : unit -> bool = "isMacOSX"
let isMacOSX = isMacOSXPred ()
@@ -51,8 +54,37 @@
let doubleMagic = "\000\005\022\007"
let doubleVersion = "\000\002\000\000"
let doubleFiller = String.make 16 '\000'
+let ressource_fork_empty_tag = "This resource fork intentionally left blank "
let finfoLength = 32L
let emptyFinderInfo () = String.make 32 '\000'
+let empty_ressource_fork =
+ "\000\000\001\000" ^
+ "\000\000\001\000" ^
+ "\000\000\000\000" ^
+ "\000\000\000\030" ^
+ ressource_fork_empty_tag ^
+ String.make (66+128) '\000' ^
+ "\000\000\001\000" ^
+ "\000\000\001\000" ^
+ "\000\000\000\000" ^
+ "\000\000\000\030" ^
+ "\000\000\000\000" ^
+ "\000\000\000\000" ^
+ "\000\028\000\030" ^
+ "\255\255"
+let empty_attribute_chunk () =
+ "\000\000" ^ (* pad *)
+ "ATTR" ^ (* magic *)
+ "\000\000\000\000" ^ (* debug tag *)
+ "\000\000\014\226" ^ (* total size *)
+ "\000\000\000\156" ^ (* data_start *)
+ "\000\000\000\000" ^ (* data_length *)
+ "\000\000\000\000" ^ (* reserved *)
+ "\000\000\000\000" ^
+ "\000\000\000\000" ^
+ "\000\000" ^ (* flags *)
+ "\000\000" ^ (* num_attrs *)
+ String.make 3690 '\000'
let getInt2 buf ofs = (Char.code buf.[ofs]) * 256 + Char.code buf.[ofs + 1]
@@ -80,25 +112,28 @@
set 0; set 1; set 2; set 3;
s
-let fail path msg =
+let fail dataFspath dataPath doubleFspath msg =
raise (Util.Transient
- (Format.sprintf "Malformed AppleDouble file '%s' (%s)"
- (Fspath.toPrintString path) msg))
+ (Format.sprintf
+ "The AppleDouble Header file '%s' \
+ associated to data file %s is malformed: %s"
+ (Fspath.toPrintString doubleFspath)
+ (Fspath.toPrintString (Fspath.concat dataFspath dataPath)) msg))
-let readDouble path inch len =
+let readDouble dataFspath dataPath doubleFspath inch len =
let buf = String.create len in
begin try
really_input inch buf 0 len
with End_of_file ->
- fail path "truncated"
+ fail dataFspath dataPath doubleFspath "truncated"
end;
buf
-let readDoubleFromOffset path inch offset len =
+let readDoubleFromOffset dataFspath dataPath doubleFspath inch offset len =
LargeFile.seek_in inch offset;
- readDouble path inch len
+ readDouble dataFspath dataPath doubleFspath inch len
-let writeDoubleFromOffset path outch offset str =
+let writeDoubleFromOffset outch offset str =
LargeFile.seek_out outch offset;
output_string outch str
@@ -109,27 +144,27 @@
begin try g () with Sys_error _ | Unix.Unix_error _ -> () end;
raise e
-let openDouble fspath path =
- let (fspath, path) = Fspath.findWorkingDir fspath path in
- let path = Fspath.appleDouble (Fspath.concat fspath path) in
- let inch = try Fs.open_in_bin path with Sys_error _ -> raise Not_found in
+let openDouble dataFspath dataPath =
+ let doubleFspath = Fspath.appleDouble (Fspath.concat dataFspath dataPath) in
+ let inch =
+ try Fs.open_in_bin doubleFspath with Sys_error _ -> raise Not_found in
protect (fun () ->
Util.convertUnixErrorsToTransient "opening AppleDouble file" (fun () ->
- let header = readDouble path inch 26 in
+ let header = readDouble dataFspath dataPath doubleFspath inch 26 in
if String.sub header 0 4 <> doubleMagic then
- fail path "bad magic number";
+ fail dataFspath dataPath doubleFspath "bad magic number";
if String.sub header 4 4 <> doubleVersion then
- fail path "bad version";
+ fail dataFspath dataPath doubleFspath "bad version";
let numEntries = getInt2 header 24 in
let entries = ref [] in
for i = 1 to numEntries do
- let entry = readDouble path inch 12 in
+ let entry = readDouble dataFspath dataPath doubleFspath inch 12 in
let id = getID entry 0 in
let ofs = getInt4 entry 4 in
let len = getInt4 entry 8 in
entries := (id, (ofs, len)) :: !entries
done;
- (path, inch, !entries)))
+ (doubleFspath, inch, !entries)))
(fun () -> close_in_noerr inch)
(****)
@@ -195,7 +230,7 @@
in
trim info
-let getFileInfos fspath path typ =
+let getFileInfos dataFspath dataPath typ =
if not (Prefs.read rsrc) then defaultInfos typ else
match typ with
(`FILE | `DIRECTORY) as typ ->
@@ -203,7 +238,9 @@
try
let (fInfo, rsrcLength) =
getFileInfosInternal
- (Fspath.toSysPath (Fspath.concat fspath path)) (typ = `FILE) in
+ (Fspath.toSysPath (Fspath.concat dataFspath dataPath))
+ (typ = `FILE)
+ in
{ ressInfo =
if rsrcLength = 0L then NoRess
else HfsRess (Uutil.Filesize.ofInt64 rsrcLength);
@@ -211,26 +248,51 @@
with Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOSYS), _, _) ->
(* Not a HFS volume. Look for an AppleDouble file *)
try
- let (doublePath, inch, entries) = openDouble fspath path in
+ let (workingDir, realPath) =
+ Fspath.findWorkingDir dataFspath dataPath in
+ let (doubleFspath, inch, entries) =
+ openDouble workingDir realPath in
let (rsrcOffset, rsrcLength) =
- try Safelist.assoc `RSRC entries with Not_found ->
+ 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
+ debug (fun () ->
+ Util.msg
+ "AppleDouble for file %s / %s: ressource fork length: %d\n"
+ (Fspath.toDebugString dataFspath) (Path.toString dataPath)
+ (Int64.to_int rsrcLength));
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 dataFspath dataPath doubleFspath "bad finder info";
+ readDoubleFromOffset
+ dataFspath dataPath doubleFspath inch ofs 32
with Not_found ->
"")
(fun () -> close_in_noerr inch)
in
+ close_in inch;
let stats =
Util.convertUnixErrorsToTransient "stating AppleDouble file"
- (fun () -> Fs.stat doublePath) in
+ (fun () -> Fs.stat doubleFspath) in
{ ressInfo =
if rsrcLength = 0L then NoRess else
AppleDoubleRess
@@ -249,7 +311,7 @@
| `Unix -> 0.
end,
Uutil.Filesize.ofInt64 rsrcLength,
- (doublePath, rsrcOffset));
+ (doubleFspath, rsrcOffset));
finfo = extractInfo typ finfo }
with Not_found ->
defaultInfos typ)
@@ -270,34 +332,37 @@
String.blit info (offset + 2) fullInfo 24 2;
fullInfo
-let setFileInfos fspath path finfo =
+let setFileInfos dataFspath dataPath finfo =
assert (finfo <> "");
Util.convertUnixErrorsToTransient "setting file informations" (fun () ->
try
- let p = Fspath.toSysPath (Fspath.concat fspath path) in
+ let p = Fspath.toSysPath (Fspath.concat dataFspath dataPath) in
let (fullFinfo, _) = getFileInfosInternal p false in
setFileInfosInternal p (insertInfo fullFinfo finfo)
with Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOSYS), _, _) ->
(* Not an HFS volume. Look for an AppleDouble file *)
+ let (workingDir, realPath) = Fspath.findWorkingDir dataFspath dataPath in
begin try
- let (doublePath, inch, entries) = openDouble fspath path in
+ let (doubleFspath, inch, entries) = openDouble workingDir realPath 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 dataFspath dataPath doubleFspath "bad finder info";
let fullFinfo =
protect
(fun () ->
- let res = readDoubleFromOffset doublePath inch ofs 32 in
+ let res =
+ readDoubleFromOffset
+ dataFspath dataPath doubleFspath inch ofs 32 in
close_in inch;
res)
(fun () -> close_in_noerr inch)
in
let outch =
- Fs.open_out_gen [Open_wronly; Open_binary] 0o600 doublePath in
+ Fs.open_out_gen [Open_wronly; Open_binary] 0o600 doubleFspath in
protect
(fun () ->
- writeDoubleFromOffset doublePath outch ofs
- (insertInfo fullFinfo finfo);
+ writeDoubleFromOffset outch ofs (insertInfo fullFinfo finfo);
close_out outch)
(fun () ->
close_out_noerr outch);
@@ -307,25 +372,39 @@
(Format.sprintf
"Unable to set the file type and creator: \n\
The AppleDouble file '%s' has no fileinfo entry."
- (Fspath.toPrintString doublePath)))
+ (Fspath.toPrintString doubleFspath)))
end
with Not_found ->
(* No AppleDouble file, create one if needed. *)
if finfo <> "F" && finfo <> "D" then begin
- let path = Fspath.appleDouble (Fspath.concat fspath path) in
+ let doubleFspath =
+ Fspath.appleDouble (Fspath.concat workingDir realPath) in
let outch =
Fs.open_out_gen
- [Open_wronly; Open_creat; Open_excl; Open_binary] 0o600 path
+ [Open_wronly; Open_creat; Open_excl; Open_binary] 0o600
+ doubleFspath
in
+ (* Apparently, for compatibility with various old versions
+ of Mac OS X that did not follow the AppleDouble specification,
+ we have to include a dummy ressource fork...
+ We also put an empty extended attribute section at the
+ end of the finder info section, mimicking the Mac OS X
+ kernel behavior. *)
protect (fun () ->
output_string outch doubleMagic;
output_string outch doubleVersion;
output_string outch doubleFiller;
- output_string outch "\000\001"; (* One entry *)
+ output_string outch "\000\002"; (* Two entries *)
output_string outch "\000\000\000\009"; (* Finder info *)
- output_string outch "\000\000\000\038"; (* offset *)
- output_string outch "\000\000\000\032"; (* length *)
+ output_string outch "\000\000\000\050"; (* offset *)
+ output_string outch "\000\000\014\176"; (* length *)
+ output_string outch "\000\000\000\002"; (* Ressource fork *)
+ output_string outch "\000\000\014\226"; (* offset *)
+ output_string outch "\000\000\001\030"; (* length *)
output_string outch (insertInfo (emptyFinderInfo ()) finfo);
+ output_string outch (empty_attribute_chunk ());
+ (* extended attributes *)
+ output_string outch empty_ressource_fork;
close_out outch)
(fun () -> close_out_noerr outch)
end
@@ -373,6 +452,10 @@
| HfsRess _ ->
Fingerprint.file fspath (ressPath path)
| AppleDoubleRess (_, _, _, len, (path, offset)) ->
+ debug (fun () ->
+ Util.msg "ressource fork fingerprint: path %s, offset %d, len %d"
+ (Fspath.toString path)
+ (Int64.to_int offset) (Uutil.Filesize.toInt len));
Fingerprint.subfile path offset len
let ressLength ress =
@@ -423,12 +506,14 @@
output_string outch "\000\002"; (* Two entries *)
output_string outch "\000\000\000\009"; (* Finder info *)
output_string outch "\000\000\000\050"; (* offset *)
- output_string outch "\000\000\000\032"; (* length *)
+ output_string outch "\000\000\014\176"; (* length *)
output_string outch "\000\000\000\002"; (* Resource fork *)
- output_string outch "\000\000\000\082"; (* offset *)
+ output_string outch "\000\000\014\226"; (* offset *)
output_string outch (setInt4 (Uutil.Filesize.toInt64 length));
(* length *)
output_string outch (emptyFinderInfo ());
+ output_string outch (empty_attribute_chunk ());
+ (* extended attributes *)
flush outch)
(fun () -> close_out_noerr outch);
outch)
Modified: trunk/src/system/system_win.ml
===================================================================
--- trunk/src/system/system_win.ml 2009-06-13 09:28:01 UTC (rev 353)
+++ trunk/src/system/system_win.ml 2009-06-15 14:26:01 UTC (rev 354)
@@ -85,6 +85,7 @@
external mkdir_impl : string -> string -> unit = "win_mkdir"
external unlink_impl : string -> string -> unit = "win_unlink"
external rename_impl : string -> string -> string -> unit = "win_rename"
+external link_impl : string -> string -> string -> unit = "win_link"
external chmod_impl : string -> string -> int -> unit = "win_chmod"
external utimes_impl :
string -> string -> float -> float -> unit = "win_utimes"
@@ -105,7 +106,7 @@
let chmod f perm = chmod_impl f (epath f) perm
let chown _ _ _ = raise (Unix.Unix_error (Unix.ENOSYS, "chown", ""))
let utimes f t1 t2 = utimes_impl f (epath f) t1 t2
-let link _ _ = raise (Unix.Unix_error (Unix.ENOSYS, "link", ""))
+let link f1 f2 = link_impl f1 (epath f1) (epath f2)
let openfile f flags perm = open_impl f (epath f) flags perm
let readlink _ = raise (Unix.Unix_error (Unix.ENOSYS, "readlink", ""))
let symlink _ _ = raise (Unix.Unix_error (Unix.ENOSYS, "symlink", ""))
Modified: trunk/src/system/system_win_stubs.c
===================================================================
--- trunk/src/system/system_win_stubs.c 2009-06-13 09:28:01 UTC (rev 353)
+++ trunk/src/system/system_win_stubs.c 2009-06-15 14:26:01 UTC (rev 354)
@@ -3,7 +3,7 @@
#include <caml/memory.h>
#include <caml/fail.h>
-#define _WIN32_WINDOWS 0x0410
+#define WINVER 0x0500
#include <wtypes.h>
#include <winbase.h>
@@ -124,6 +124,18 @@
CAMLreturn (Val_unit);
}
+CAMLprim value win_link(value path1, value wpath1, value wpath2)
+{
+ CAMLparam3(path1, wpath1, wpath2);
+
+ if (!CreateHardLinkW((LPWSTR)String_val(wpath2), (LPWSTR)String_val(wpath1),
+ NULL)) {
+ win32_maperr (GetLastError ());
+ uerror("rename", path1);
+ }
+ CAMLreturn (Val_unit);
+}
+
CAMLprim value win_chmod (value path, value wpath, value perm) {
DWORD attr;
CAMLparam3(path, wpath, perm);
Modified: trunk/src/unicode.ml
===================================================================
--- trunk/src/unicode.ml 2009-06-13 09:28:01 UTC (rev 353)
+++ trunk/src/unicode.ml 2009-06-15 14:26:01 UTC (rev 354)
@@ -836,7 +836,7 @@
i = l ||
let c = get s i in
if c < 0x80 then
- scan s (i + 1) l
+ c <> 0 && scan s (i + 1) l
else if c < 0xE0 then begin
(* 80 - 7FF *)
c >= 0xc2 && i + 1 < l &&
@@ -850,7 +850,7 @@
let c2 = get s (i + 2) in
(c1 lor c2) land 0xc0 = 0x80 &&
let v = c lsl 12 + c1 lsl 6 + c2 - 0xe2080 in
- v >= 0x800 && (v < 0xd800 || v > 0xdfff) &&
+ v >= 0x800 && (v < 0xd800 || (v > 0xdfff && v <> 0xfffe && v <> 0xffff)) &&
scan s (i + 3) l
end else begin
(* 10000 - 10FFFF *)
More information about the Unison-hackers
mailing list