[Unison-hackers] [unison-svn] r333 - in trunk/src: . lwt system system/generic system/win ubase
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Fri May 15 10:34:52 EDT 2009
Author: vouillon
Date: 2009-05-15 10:34:43 -0400 (Fri, 15 May 2009)
New Revision: 333
Added:
trunk/src/system.ml
trunk/src/system/
trunk/src/system/generic/
trunk/src/system/generic/system_impl.ml
trunk/src/system/system_generic.ml
trunk/src/system/system_intf.ml
trunk/src/system/system_win.ml
trunk/src/system/system_win_stubs.c
trunk/src/system/win/
trunk/src/system/win/system_impl.ml
Removed:
trunk/src/system.ml
trunk/src/system_generic.ml
trunk/src/system_intf.ml
trunk/src/system_win.ml
trunk/src/system_win_stubs.c
Modified:
trunk/src/.depend
trunk/src/Makefile.OCaml
trunk/src/RECENTNEWS
trunk/src/case.ml
trunk/src/case.mli
trunk/src/copy.ml
trunk/src/fs.ml
trunk/src/fs.mli
trunk/src/fspath.ml
trunk/src/lwt/lwt_unix.ml
trunk/src/mkProjectInfo.ml
trunk/src/os.ml
trunk/src/osx.ml
trunk/src/pty.c
trunk/src/remote.ml
trunk/src/terminal.ml
trunk/src/ubase/depend
trunk/src/uigtk2.ml
Log:
* Bumped minor version: incompatible protocol changes
* The use of the Windows Unicode API is now controlled via the
"unicode" directive
* Fixed bug in GTK UI: buttons could be incorrectly reenabled during
synchronization
* Improved error message when trying to synchronize a symlink to a
Windows machine
* Fixed compilation warnings in lwt_unix.ml and pty.c
* Added some missing convertUnixErrorsToTransient
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/.depend 2009-05-15 14:34:43 UTC (rev 333)
@@ -12,7 +12,7 @@
lwt/lwt.cmi common.cmi
fileutil.cmi:
fingerprint.cmi: uutil.cmi path.cmi fspath.cmi
-fs.cmi: system_intf.cmo fspath.cmi
+fs.cmi: system/system_intf.cmo fspath.cmi
fspath.cmi: system.cmi path.cmi name.cmi
globals.cmi: ubase/prefs.cmi path.cmi lwt/lwt.cmi common.cmi
lock.cmi: system.cmi
@@ -27,7 +27,7 @@
sortri.cmi: common.cmi
stasher.cmi: ubase/prefs.cmi path.cmi os.cmi fspath.cmi
strings.cmi:
-system.cmi: system_intf.cmo
+system.cmi: system/system_intf.cmo
terminal.cmi:
test.cmi:
transfer.cmi: uutil.cmi lwt/lwt.cmi
@@ -87,8 +87,8 @@
fileutil.cmx: fileutil.cmi
fingerprint.cmo: uutil.cmi ubase/util.cmi fspath.cmi fs.cmi fingerprint.cmi
fingerprint.cmx: uutil.cmx ubase/util.cmx fspath.cmx fs.cmx fingerprint.cmi
-fs.cmo: ubase/util.cmi system.cmi fspath.cmi fs.cmi
-fs.cmx: ubase/util.cmx system.cmx fspath.cmx fs.cmi
+fs.cmo: ubase/util.cmi fspath.cmi fs.cmi
+fs.cmx: ubase/util.cmx fspath.cmx fs.cmi
fspath.cmo: uutil.cmi ubase/util.cmi system.cmi ubase/rx.cmi path.cmi \
name.cmi fileutil.cmi fspath.cmi
fspath.cmx: uutil.cmx ubase/util.cmx system.cmx ubase/rx.cmx path.cmx \
@@ -167,14 +167,8 @@
fileutil.cmx fileinfo.cmx copy.cmx common.cmx stasher.cmi
strings.cmo: strings.cmi
strings.cmx: strings.cmi
-system_generic.cmo:
-system_generic.cmx:
-system_intf.cmo:
-system_intf.cmx:
-system.cmo: system_win.cmo system.cmi
-system.cmx: system_win.cmx system.cmi
-system_win.cmo: unicode.cmi ubase/rx.cmi
-system_win.cmx: unicode.cmx ubase/rx.cmx
+system.cmo: system.cmi
+system.cmx: system.cmi
terminal.cmo: ubase/safelist.cmi ubase/rx.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
terminal.cmi
terminal.cmx: ubase/safelist.cmx ubase/rx.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
@@ -289,6 +283,12 @@
lwt/lwt_util.cmx: lwt/lwt.cmx lwt/lwt_util.cmi
lwt/pqueue.cmo: lwt/pqueue.cmi
lwt/pqueue.cmx: lwt/pqueue.cmi
+system/system_generic.cmo:
+system/system_generic.cmx:
+system/system_intf.cmo:
+system/system_intf.cmx:
+system/system_win.cmo: unicode.cmi ubase/rx.cmi
+system/system_win.cmx: unicode.cmx ubase/rx.cmx
ubase/myMap.cmo: ubase/myMap.cmi
ubase/myMap.cmx: ubase/myMap.cmi
ubase/prefs.cmo: ubase/util.cmi ubase/uarg.cmi system.cmi ubase/safelist.cmi \
@@ -325,3 +325,11 @@
ubase/uarg.cmi:
ubase/uprintf.cmi:
ubase/util.cmi: system.cmi
+lwt/example/editor.cmo: lwt/lwt_unix.cmi
+lwt/example/editor.cmx: lwt/lwt_unix.cmx
+lwt/example/relay.cmo: lwt/lwt_unix.cmi lwt/lwt.cmi
+lwt/example/relay.cmx: lwt/lwt_unix.cmx lwt/lwt.cmx
+system/generic/system_impl.cmo: system/system_generic.cmo
+system/generic/system_impl.cmx: system/system_generic.cmx
+system/win/system_impl.cmo: system/system_win.cmo system/system_generic.cmo
+system/win/system_impl.cmx: system/system_win.cmx system/system_generic.cmx
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/Makefile.OCaml 2009-05-15 14:34:43 UTC (rev 333)
@@ -83,8 +83,9 @@
####################################################################
### Default parameters
-INCLFLAGS=-I lwt -I ubase
+INCLFLAGS=-I lwt -I ubase -I system
CAMLFLAGS+=$(INCLFLAGS)
+CAMLFLAGS+=-I system/$(SYSTEM)
ifeq ($(OSARCH),win32)
# Win32 system
@@ -98,8 +99,9 @@
# issue."
# CLIBS+=-cclib win32rc/unison.res
# STATICLIBS+=-cclib win32rc/unison.res
- COBJS+=system_win_stubs$(OBJ_EXT)
- WINOBJS=system_win.cmo
+ COBJS+=system/system_win_stubs$(OBJ_EXT)
+ WINOBJS=system/system_win.cmo
+ SYSTEM=win
CLIBS+=-cclib "-link win32rc/unison.res"
STATICLIBS+=-cclib "-link win32rc/unison.res"
buildexecutable::
@@ -110,8 +112,9 @@
ifeq ($(OSARCH),win32gnuc)
CWD=.
EXEC_EXT=.exe
- COBJS+=system_win_stubs$(OBJ_EXT)
- WINOBJS=system_win.cmo
+ COBJS+=system/system_win_stubs$(OBJ_EXT)
+ WINOBJS=system/system_win.cmo
+ SYSTEM=win
CLIBS+=-cclib win32rc/unison.res.lib
STATIC=false # Cygwin is not MinGW :-(
buildexecutable::
@@ -119,6 +122,8 @@
else
CWD=$(shell pwd)
EXEC_EXT=
+ WINOBJS=
+ SYSTEM=generic
# openpty is in the libutil library
ifneq ($(OSARCH),solaris)
ifneq ($(OSARCH),osx)
@@ -183,7 +188,9 @@
ubase/rx.cmo \
\
unicode_tables.cmo unicode.cmo \
- $(WINOBJS) system_generic.cmo system.cmo \
+ $(WINOBJS) system/system_generic.cmo \
+ system/$(SYSTEM)/system_impl.cmo \
+ system.cmo \
\
ubase/projectInfo.cmo ubase/myMap.cmo ubase/safelist.cmo \
ubase/uprintf.cmo ubase/util.cmo ubase/uarg.cmo \
@@ -275,6 +282,9 @@
# Include an automatically generated list of dependencies
include .depend
+# Additional dependencied depending on the system
+system.cmo fs.cmo: system/$(SYSTEM)/system_impl.cmo
+system.cmx fs.cmx: system/$(SYSTEM)/system_impl.cmx
ifeq ($(OSARCH), OpenBSD)
ifeq ($(shell echo type ocamldot | ksh), file)
@@ -293,7 +303,7 @@
# Rebuild dependencies (must be invoked manually)
.PHONY: depend
depend::
- ocamldep $(INCLFLAGS) *.mli *.ml */*.ml */*.mli > .depend
+ ocamldep $(INCLFLAGS) *.mli *.ml */*.ml */*.mli */*/*.ml */*/*.mli > .depend
ifdef OCAMLDOT
echo 'digraph G {' > dot.tmp
echo '{ rank = same; "Fileinfo"; "Props"; "Fspath"; "Os"; "Path"; }'\
@@ -377,7 +387,7 @@
%.o %.obj: %.c
@echo "$(OCAMLOPT): $< ---> $@"
- $(CAMLC) $(CAMLFLAGS) -c $(CWD)/$<
+ $(CAMLC) $(CAMLFLAGS) -ccopt -o -ccopt $(CWD)/$@ -c $(CWD)/$<
$(NAME)$(EXEC_EXT): $(CAMLOBJS) $(COBJS)
@echo Linking $@
@@ -402,6 +412,7 @@
-$(RM) -r *.o core gmon.out *~ .*~
-$(RM) -r *.obj *.lib *.exp
-$(RM) -r *.tmp *.bak?.tmp .*.bak?.tmp
+ -$(RM) system/*.cm[iox] system/*.{o,obj}
.PHONY: paths
paths:
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/RECENTNEWS 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,3 +1,16 @@
+CHANGES FROM VERSION 2.34.0
+
+* Bumped minor version: incompatible protocol changes
+* The use of the Windows Unicode API is now controlled via the
+ "unicode" directive
+* Fixed bug in GTK UI: buttons could be incorrectly reenabled during
+ synchronization
+* Improved error message when trying to synchronize a symlink to a
+ Windows machine
+* Fixed compilation warnings in lwt_unix.ml and pty.c
+* Added some missing convertUnixErrorsToTransient
+
+-------------------------------
CHANGES FROM VERSION 2.33.2
* Added an abstraction layer over Unix/Sys modules in order to be able
Modified: trunk/src/case.ml
===================================================================
--- trunk/src/case.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/case.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -34,18 +34,33 @@
^ "useful to set the flag manually (e.g. when running Unison on a "
^ "Unix system with a FAT [Windows] volume mounted).")
-let unicodeEncoding =
- Prefs.createBool "unicode" false
- "!assume Unicode encoding in case insensitive mode"
- "When set to {\\tt true}, this flag causes Unison to perform \
- case insensitive file comparisons assuming Unicode encoding"
-
(* Defining this variable as a preference ensures that it will be propagated
to the other host during initialization *)
let someHostIsInsensitive =
Prefs.createBool "someHostIsInsensitive" false
"*Pseudo-preference for internal use only" ""
+let unicodePref =
+ Prefs.createString "unicode" "default"
+ "!assume Unicode encoding in case insensitive mode"
+ "When set to {\\tt true}, this flag causes Unison to perform \
+ case insensitive file comparisons assuming Unicode encoding"
+
+let unicodeEncoding =
+ Prefs.createBool "unicodeEncoding" false
+ "*Pseudo-preference for internal use only" ""
+
+(* Whether we default to Unicode encoding on OSX and Windows *)
+(* !!! the minor version should be increased whenever *)
+(* !!! this default is changed *)
+let defaultToUnicode = false
+
+let useUnicode pref b =
+ pref = "yes" || pref = "true" ||
+ (defaultToUnicode && pref = "default" && b)
+
+let useUnicodeAPI pref = useUnicode pref (Util.osType = `Win32)
+
(* During startup the client determines the case sensitivity of each root. *)
(* If any root is case insensitive, all roots must know it; we ensure this *)
(* by storing the information in a pref so that it is propagated to the *)
@@ -54,7 +69,8 @@
Prefs.set someHostIsInsensitive
(Prefs.read caseInsensitiveMode = "yes" ||
Prefs.read caseInsensitiveMode = "true" ||
- (Prefs.read caseInsensitiveMode = "default" && b))
+ (Prefs.read caseInsensitiveMode = "default" && b));
+ Prefs.set unicodeEncoding (useUnicode (Prefs.read unicodePref) b)
(****)
Modified: trunk/src/case.mli
===================================================================
--- trunk/src/case.mli 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/case.mli 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,7 +1,9 @@
(* Unison file synchronizer: src/case.mli *)
(* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *)
+val unicodePref : string Prefs.t
val unicodeEncoding : bool Prefs.t
+val useUnicodeAPI : string -> bool
type mode
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/copy.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -565,10 +565,11 @@
info.Fileinfo.typ = `FILE
&& (match checkSize with
`MakeWriteableAndCheckNonempty ->
- let n = Fspath.concat fspathTo pathTo in
let perms = Props.perms info.Fileinfo.desc in
let perms' = perms lor 0o600 in
- Fs.chmod n perms';
+ Util.convertUnixErrorsToTransient
+ "making target writable"
+ (fun () -> Fs.chmod (Fspath.concat fspathTo pathTo) perms');
Props.length info.Fileinfo.desc > Uutil.Filesize.zero
| `CheckDataSize desc ->
Props.length info.Fileinfo.desc = Props.length desc
Modified: trunk/src/fs.ml
===================================================================
--- trunk/src/fs.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/fs.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -15,44 +15,46 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
+module System = System_impl.Fs
+
type fspath = Fspath.t
type dir_handle = System.dir_handle
-let symlink l f = System.symlink l (Fspath.toSysPath f)
+let symlink l f = System.symlink l (Fspath.toString f)
-let readlink f = System.readlink (Fspath.toSysPath f)
+let readlink f = System.readlink (Fspath.toString f)
-let chown f usr grp = System.chown (Fspath.toSysPath f) usr grp
+let chown f usr grp = System.chown (Fspath.toString f) usr grp
-let chmod f mode = System.chmod (Fspath.toSysPath f) mode
+let chmod f mode = System.chmod (Fspath.toString f) mode
-let utimes f t1 t2 = System.utimes (Fspath.toSysPath f) t1 t2
+let utimes f t1 t2 = System.utimes (Fspath.toString f) t1 t2
-let unlink f = System.unlink (Fspath.toSysPath f)
+let unlink f = System.unlink (Fspath.toString f)
-let rmdir f = System.rmdir (Fspath.toSysPath f)
+let rmdir f = System.rmdir (Fspath.toString f)
-let mkdir f mode = System.mkdir (Fspath.toSysPath f) mode
+let mkdir f mode = System.mkdir (Fspath.toString f) mode
-let rename f f' = System.rename (Fspath.toSysPath f) (Fspath.toSysPath f')
+let rename f f' = System.rename (Fspath.toString f) (Fspath.toString f')
-let stat f = System.stat (Fspath.toSysPath f)
+let stat f = System.stat (Fspath.toString f)
-let lstat f = System.lstat (Fspath.toSysPath f)
+let lstat f = System.lstat (Fspath.toString f)
-let openfile f flags perms = System.openfile (Fspath.toSysPath f) flags perms
+let openfile f flags perms = System.openfile (Fspath.toString f) flags perms
-let opendir f = System.opendir (Fspath.toSysPath f)
+let opendir f = System.opendir (Fspath.toString f)
let readdir = System.readdir
let closedir = System.closedir
let open_in_gen flags mode f =
- System.open_in_gen flags mode (Fspath.toSysPath f)
+ System.open_in_gen flags mode (Fspath.toString f)
let open_out_gen flags mode f =
- System.open_out_gen flags mode (Fspath.toSysPath f)
+ System.open_out_gen flags mode (Fspath.toString f)
(****)
@@ -73,11 +75,6 @@
d
let canSetTime f =
- Util.osType <> `Win32 ||
- try
- Unix.access (System.fspathToString (Fspath.toSysPath f)) [Unix.W_OK];
- true
- with
- Unix.Unix_error _ -> false
+ System.canSetTime (Util.osType <> `Win32) (Fspath.toString f)
-let useUnicodeEncoding _ = ()
+let setUnicodeEncoding = System.setUnicodeEncoding
Modified: trunk/src/fs.mli
===================================================================
--- trunk/src/fs.mli 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/fs.mli 2009-05-15 14:34:43 UTC (rev 333)
@@ -8,4 +8,4 @@
val digestFile : Fspath.t -> string
val canSetTime : Fspath.t -> bool
-val useUnicodeEncoding : bool -> unit
+val setUnicodeEncoding : bool -> unit
Modified: trunk/src/fspath.ml
===================================================================
--- trunk/src/fspath.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/fspath.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -28,11 +28,7 @@
(* All fspaths are absolute *)
(* - *)
-module Fs = struct
- let getcwd = System.getcwd
- let chdir = System.chdir
- let readlink = System.readlink
-end
+module Fs = System_impl.Fs
let debug = Util.debug "fspath"
let debugverbose = Util.debug "fsspath+"
@@ -240,9 +236,7 @@
(* Filename, and Sys modules of ocaml have subtle differences under Windows *)
(* and Unix. So, be very careful with any changes !!! *)
let canonizeFspath p0 =
- let p =
- System.fspathFromString
- (match p0 with None -> "." | Some "" -> "." | Some s -> s) in
+ let p = match p0 with None -> "." | Some "" -> "." | Some s -> s in
let p' =
begin
let original = Fs.getcwd() in
@@ -251,7 +245,7 @@
(Fs.chdir p; (* This might raise Sys_error *)
Fs.getcwd()) in
Fs.chdir original;
- System.fspathToString newp
+ newp
with
Sys_error why ->
(* We could not chdir to p. Either *)
@@ -264,18 +258,17 @@
(* fails, we just quit. This works nicely for most cases of (1), *)
(* it works for (2), and on (3) it may leave a mess for someone *)
(* else to pick up. *)
- let p = System.fspathToString p in
let p = if Util.osType = `Win32 then Fileutil.backslashes2forwardslashes p else p in
if isRootDir p then raise
(Util.Fatal (Printf.sprintf
"Cannot find canonical name of root directory %s\n(%s)" p why));
let parent = myDirname p in
let parent' = begin
- (try Fs.chdir (System.fspathFromString parent) with
+ (try Fs.chdir parent with
Sys_error why2 -> raise (Util.Fatal (Printf.sprintf
"Cannot find canonical name of %s: unable to cd either to it\n
(%s)\nor to its parent %s\n(%s)" p why parent why2)));
- System.fspathToString (Fs.getcwd()) end in
+ Fs.getcwd() end in
Fs.chdir original;
let bn = Filename.basename p in
if bn="" then parent'
@@ -307,30 +300,27 @@
let maxlinks = 100
let findWorkingDir fspath path =
- let abspath = toSysPath (concat fspath path) in
+ let abspath = toString (concat fspath path) in
let realpath =
if not (Path.followLink path) then abspath else
let rec followlinks n p =
if n>=maxlinks then
raise
(Util.Transient (Printf.sprintf
- "Too many symbolic links from %s"
- (System.fspathToPrintString abspath)));
+ "Too many symbolic links from %s" abspath));
try
let link = Fs.readlink p in
let linkabs =
if Filename.is_relative link then
- System.fspathConcat (System.fspathDirname p) link
- else System.fspathFromString link in
+ Fs.fspathConcat (Fs.fspathDirname p) link
+ else link in
followlinks (n+1) linkabs
with
Unix.Unix_error _ -> p in
followlinks 0 abspath in
- let realpath = System.fspathToString realpath in
if isRootDir realpath then
raise (Util.Transient(Printf.sprintf
- "The path %s is a root directory"
- (System.fspathToPrintString abspath)));
+ "The path %s is a root directory" abspath));
let realpath = Fileutil.removeTrailingSlashes realpath in
let p = Filename.basename realpath in
debug
Modified: trunk/src/lwt/lwt_unix.ml
===================================================================
--- trunk/src/lwt/lwt_unix.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/lwt/lwt_unix.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -280,8 +280,7 @@
let system cmd =
match Unix.fork () with
0 -> begin try
- Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
- assert false
+ Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
with _ ->
exit 127
end
@@ -380,8 +379,7 @@
Unix.close output
end;
List.iter Unix.close toclose;
- Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
- exit 127
+ Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
| id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
@@ -423,8 +421,7 @@
Unix.dup2 output Unix.stdout; Unix.close output;
Unix.dup2 error Unix.stderr; Unix.close error;
List.iter Unix.close toclose;
- Unix.execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env;
- exit 127
+ Unix.execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
| id -> Hashtbl.add popen_processes proc id
let open_process_full cmd env =
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/mkProjectInfo.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -5,8 +5,8 @@
let projectName = "unison"
let majorVersion = 2
-let minorVersion = 33
-let pointVersionOrigin = 325 (* Revision that corresponds to point version 0 *)
+let minorVersion = 34
+let pointVersionOrigin = 332 (* 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 @@
Str.matched_group 1 str;;
let extract_int re str = int_of_string (extract_str re str);;
-let revisionString = "$Rev: 327$";;
+let revisionString = "$Rev: 332$";;
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:
@@ -148,3 +148,4 @@
+
Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/os.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -210,7 +210,11 @@
Fs.symlink l abspath)
else
fun fspath path l ->
- raise (Util.Transient "symlink not supported under Win32")
+ raise (Util.Transient
+ (Format.sprintf
+ "Cannot create symlink \"%s\": \
+ symlinks are not supported under Windows"
+ (Fspath.toPrintString (Fspath.concat fspath path))))
(* Create a new directory, using the permissions from the given props *)
let createDir fspath path props =
Modified: trunk/src/osx.ml
===================================================================
--- trunk/src/osx.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/osx.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -230,7 +230,9 @@
"")
(fun () -> close_in_noerr inch)
in
- let stats = Fs.stat doublePath in
+ let stats =
+ Util.convertUnixErrorsToTransient "stating AppleDouble file"
+ (fun () -> Fs.stat doublePath) in
{ ressInfo =
if rsrcLength = 0L then NoRess else
AppleDoubleRess
Modified: trunk/src/pty.c
===================================================================
--- trunk/src/pty.c 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/pty.c 2009-05-15 14:34:43 UTC (rev 333)
@@ -52,12 +52,14 @@
#else // not HAS_OPENPTY
+#define Nothing ((value) 0)
+
CAMLprim value setControllingTerminal(value fdVal) {
- unix_error (ENOSYS, "setControllingTerminal", NULL);
+ unix_error (ENOSYS, "setControllingTerminal", Nothing);
}
CAMLprim value c_openpty() {
- unix_error (ENOSYS, "openpty", NULL);
+ unix_error (ENOSYS, "openpty", Nothing);
}
#endif
Modified: trunk/src/remote.ml
===================================================================
--- trunk/src/remote.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/remote.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -15,14 +15,6 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
-
-(*
-XXX
-- Check exception handling
-- Use Lwt_unix.system for the merge function
- (Unix.open_process_in for diff)
-*)
-
let (>>=) = Lwt.bind
let debug = Trace.debug "remote"
@@ -474,21 +466,17 @@
(* List containing the connected hosts and the file descriptors of
the communication. *)
-(*
-(* Perhaps the list would be better indexed by root
- (host name [+ user name] [+ socket]) ... *)
-let connectedHosts = ref []
+let connectionsByHosts = ref []
(* Gets the Read/Write file descriptors for a host;
the connection must have been set up by canonizeRoot before calling *)
let hostConnection host =
- try Safelist.assoc host !connectedHosts
+ try Safelist.assoc host !connectionsByHosts
with Not_found ->
- raise(Util.Fatal "hostConnection")
-*)
+ raise(Util.Fatal "Remote.hostConnection")
-(* connectedHosts is a list of command-line roots, their corresponding
- canonical host names and canonical fspaths, and their connections.
+(* connectedHosts is a list of command-line roots and their corresponding
+ canonical host names.
Local command-line roots are not in the list.
Although there can only be one remote host per sync, it's possible
connectedHosts to hold more than one hosts if more than one sync is
@@ -497,23 +485,7 @@
same canonical root.
*)
let connectedHosts = ref []
-let hostConnection host = (* host must be canonical *)
- let rec loop = function
- [] -> raise(Util.Fatal "Remote.hostConnection")
- | (cl,h,fspath,conn)::tl -> if h=host then conn else loop tl in
- loop !connectedHosts
-let canonize clroot = (* connection for clroot must have been set up already *)
- match clroot with
- Clroot.ConnectLocal s -> (Common.Local, Fspath.canonize s)
- | _ ->
- let rec loop = function
- [] -> raise(Util.Fatal "Remote.canonize")
- | (cl,h,fspath,conn)::tl ->
- if cl=clroot then (Common.Remote h,fspath) else loop tl in
- loop !connectedHosts
-
-
(**********************************************************************
CLIENT/SERVER PROTOCOLS
**********************************************************************)
@@ -943,37 +915,66 @@
end;
initConnection i2 o1
+let canonizeLocally s unicode =
+ (* We need to select the proper API in order to compute correctly the
+ canonical fspath *)
+ Fs.setUnicodeEncoding (Case.useUnicodeAPI unicode);
+ Fspath.canonize s
+
let canonizeOnServer =
registerServerCmd "canonizeOnServer"
- (fun _ s -> Lwt.return (Os.myCanonicalHostName, Fspath.canonize s))
+ (fun _ (s, unicode) ->
+ Lwt.return (Os.myCanonicalHostName, canonizeLocally s unicode))
+let canonize clroot = (* connection for clroot must have been set up already *)
+ match clroot with
+ Clroot.ConnectLocal s ->
+ (Common.Local, canonizeLocally s (Prefs.read Case.unicodePref))
+ | _ ->
+ match
+ try
+ Some (Safelist.assoc clroot !connectedHosts)
+ with Not_found ->
+ None
+ with
+ None -> raise (Util.Fatal "Remote.canonize")
+ | Some (h, fspath, _) -> (Common.Remote h, fspath)
+
+let listReplace v l = v :: Safelist.remove_assoc (fst v) l
+
+let rec hostFspath clroot =
+ try
+ let (_, _, ioServer) = Safelist.assoc clroot !connectedHosts in
+ Some (Lwt.return ioServer)
+ with Not_found ->
+ None
+
let canonizeRoot rootName clroot termInteract =
+ let unicode = Prefs.read Case.unicodePref in
let finish ioServer s =
- canonizeOnServer ioServer s >>= (fun (host, fspath) ->
- connectedHosts := (clroot,host,fspath,ioServer)::(!connectedHosts);
+ (* We need to always compute the fspath as it depends on
+ unicode settings *)
+ canonizeOnServer ioServer (s, unicode) >>= (fun (host, fspath) ->
+ connectedHosts :=
+ listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
+ connectionsByHosts := listReplace (host, ioServer) !connectionsByHosts;
Lwt.return (Common.Remote host,fspath)) in
- let rec hostfspath = function
- [] -> None
- | (clroot',host,fspath,_)::tl ->
- if clroot=clroot'
- then Some(Lwt.return(Common.Remote host,fspath))
- else hostfspath tl in
match clroot with
Clroot.ConnectLocal s ->
- Lwt.return (Common.Local, Fspath.canonize s)
+ Lwt.return (Common.Local, canonizeLocally s unicode)
| Clroot.ConnectBySocket(host,port,s) ->
- (match hostfspath !connectedHosts with
+ begin match hostFspath clroot with
Some x -> x
- | None ->
- buildSocketConnection host port >>= (fun ioServer ->
- finish ioServer s))
+ | None -> buildSocketConnection host port
+ end >>= fun ioServer ->
+ finish ioServer s
| Clroot.ConnectByShell(shell,host,userOpt,portOpt,s) ->
- (match hostfspath !connectedHosts with
+ begin match hostFspath clroot with
Some x -> x
- | None ->
- buildShellConnection
- shell host userOpt portOpt rootName termInteract >>=
- (fun ioServer -> finish ioServer s))
+ | None -> buildShellConnection
+ shell host userOpt portOpt rootName termInteract
+ end >>= fun ioServer ->
+ finish ioServer s
(* A new interface, useful for terminal interaction, it should
eventually replace canonizeRoot and buildShellConnection *)
@@ -993,80 +994,97 @@
Clroot.ConnectLocal s ->
None
| Clroot.ConnectBySocket(host,port,s) ->
- (* This check isn't foolproof as the host in the clroot might not be canonical *)
- if (Safelist.exists (fun (clroot',_,_,_) -> clroot=clroot') !connectedHosts)
- then None
- else begin
- let ioServer = Lwt_unix.run(buildSocketConnection host port) in
- let (host,fspath) = Lwt_unix.run(canonizeOnServer ioServer s) in
- connectedHosts := (clroot,host,fspath,ioServer)::(!connectedHosts);
- None
- end
+ Lwt_unix.run
+ (begin match hostFspath clroot with
+ Some x -> x
+ | None -> buildSocketConnection host port
+ end >>= fun ioServer ->
+ (* We need to always compute the fspath as it depends on
+ unicode settings *)
+ let unicode = Prefs.read Case.unicodePref in
+ canonizeOnServer ioServer (s, unicode) >>= fun (host, fspath) ->
+ connectedHosts :=
+ listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
+ connectionsByHosts :=
+ listReplace (host, ioServer) !connectionsByHosts;
+ Lwt.return ());
+ None
| Clroot.ConnectByShell(shell,host,userOpt,portOpt,s) ->
- if (Safelist.exists (fun (clroot',_,_,_) -> clroot=clroot') !connectedHosts)
- then None
- else begin
- let remoteCmd =
- (if Prefs.read serverCmd="" then Uutil.myName
- else Prefs.read serverCmd)
- ^ (if Prefs.read addversionno then "-" ^ Uutil.myMajorVersion else "")
- ^ " -server" in
- let userArgs =
- match userOpt with
- None -> []
- | Some user -> ["-l"; user] in
- let portArgs =
- match portOpt with
- None -> []
- | Some port -> ["-p"; port] in
- let shellCmd =
- (if shell = "ssh" then
- Prefs.read sshCmd
- else if shell = "rsh" then
- Prefs.read rshCmd
- else
- shell) in
- let shellCmdArgs =
- (if shell = "ssh" then
- Prefs.read sshargs
- else if shell = "rsh" then
- Prefs.read rshargs
- else
- "") in
- let preargs =
- ([shellCmd]@userArgs at portArgs@
- [host]@
- (if shell="ssh" then ["-e none"] else [])@
- [shellCmdArgs;remoteCmd]) in
- (* Split compound arguments at space chars, to make
- create_process happy *)
- let args =
- Safelist.concat
- (Safelist.map (fun s -> Util.splitIntoWords s ' ') preargs) in
- let argsarray = Array.of_list args in
- let (i1,o1) = Unix.pipe() in
- let (i2,o2) = Unix.pipe() in
- (* We need to make sure that there is only one reader and one
- writer by pipe, so that, when one side of the connection
- dies, the other side receives an EOF or a SIGPIPE. *)
- Unix.set_close_on_exec i2;
- Unix.set_close_on_exec o1;
- (* We add CYGWIN=binmode to the environment before calling
- ssh because the cygwin implementation on Windows sometimes
- puts the pipe in text mode (which does end of line
- translation). Specifically, if unison is invoked from
- a DOS command prompt or other non-cygwin context, the pipe
- goes into text mode; this does not happen if unison is
- invoked from cygwin's bash. By setting CYGWIN=binmode
- we force the pipe to remain in binary mode. *)
- System.putenv "CYGWIN" "binmode";
- debug (fun ()-> Util.msg "Shell connection: %s (%s)\n"
- shellCmd (String.concat ", " args));
- let (term,pid) =
- Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr in
- (* after terminal interact, remember to close i1 and o2 *)
- Some(i1,i2,o1,o2,s,term,clroot,pid)
- end
+ match hostFspath clroot with
+ Some x ->
+ let unicode = Prefs.read Case.unicodePref in
+ (* We recompute the fspath as it may have changed due to
+ unicode settings *)
+ Lwt_unix.run
+ (x >>= fun ioServer ->
+ canonizeOnServer ioServer (s, unicode) >>= fun (host, fspath) ->
+ connectedHosts :=
+ listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
+ connectionsByHosts :=
+ listReplace (host, ioServer) !connectionsByHosts;
+ Lwt.return ());
+ None
+ | None ->
+ let remoteCmd =
+ (if Prefs.read serverCmd="" then Uutil.myName
+ else Prefs.read serverCmd)
+ ^ (if Prefs.read addversionno then "-" ^ Uutil.myMajorVersion else "")
+ ^ " -server" in
+ let userArgs =
+ match userOpt with
+ None -> []
+ | Some user -> ["-l"; user] in
+ let portArgs =
+ match portOpt with
+ None -> []
+ | Some port -> ["-p"; port] in
+ let shellCmd =
+ (if shell = "ssh" then
+ Prefs.read sshCmd
+ else if shell = "rsh" then
+ Prefs.read rshCmd
+ else
+ shell) in
+ let shellCmdArgs =
+ (if shell = "ssh" then
+ Prefs.read sshargs
+ else if shell = "rsh" then
+ Prefs.read rshargs
+ else
+ "") in
+ let preargs =
+ ([shellCmd]@userArgs at portArgs@
+ [host]@
+ (if shell="ssh" then ["-e none"] else [])@
+ [shellCmdArgs;remoteCmd]) in
+ (* Split compound arguments at space chars, to make
+ create_process happy *)
+ let args =
+ Safelist.concat
+ (Safelist.map (fun s -> Util.splitIntoWords s ' ') preargs) in
+ let argsarray = Array.of_list args in
+ let (i1,o1) = Unix.pipe() in
+ let (i2,o2) = Unix.pipe() in
+ (* We need to make sure that there is only one reader and one
+ writer by pipe, so that, when one side of the connection
+ dies, the other side receives an EOF or a SIGPIPE. *)
+ Unix.set_close_on_exec i2;
+ Unix.set_close_on_exec o1;
+ (* We add CYGWIN=binmode to the environment before calling
+ ssh because the cygwin implementation on Windows sometimes
+ puts the pipe in text mode (which does end of line
+ translation). Specifically, if unison is invoked from
+ a DOS command prompt or other non-cygwin context, the pipe
+ goes into text mode; this does not happen if unison is
+ invoked from cygwin's bash. By setting CYGWIN=binmode
+ we force the pipe to remain in binary mode. *)
+ System.putenv "CYGWIN" "binmode";
+ debug (fun ()-> Util.msg "Shell connection: %s (%s)\n"
+ shellCmd (String.concat ", " args));
+ let (term,pid) =
+ Terminal.create_session shellCmd argsarray i1 o2 Unix.stderr in
+ (* after terminal interact, remember to close i1 and o2 *)
+ Some(i1,i2,o1,o2,s,term,clroot,pid)
let openConnectionPrompt = function
(i1,i2,o1,o2,s,Some fdTerm,clroot,pid) ->
@@ -1083,9 +1101,15 @@
let openConnectionEnd (i1,i2,o1,o2,s,_,clroot,pid) =
Unix.close i1; Unix.close o2;
- let ioServer = Lwt_unix.run (initConnection i2 o1) in
- let (host,fspath) = Lwt_unix.run(canonizeOnServer ioServer s) in
- connectedHosts := (clroot,host,fspath,ioServer)::(!connectedHosts)
+ Lwt_unix.run
+ (initConnection i2 o1 >>= fun ioServer ->
+ let unicode = Prefs.read Case.unicodePref in
+ canonizeOnServer ioServer (s, unicode) >>= fun (host, fspath) ->
+ connectedHosts :=
+ listReplace (clroot, (host, fspath, ioServer)) !connectedHosts;
+ connectionsByHosts :=
+ listReplace (host, ioServer) !connectionsByHosts;
+ Lwt.return ())
let openConnectionCancel (i1,i2,o1,o2,s,fdopt,clroot,pid) =
try Unix.kill pid Sys.sigkill with _ -> ();
Added: trunk/src/system/generic/system_impl.ml
===================================================================
--- trunk/src/system/generic/system_impl.ml (rev 0)
+++ trunk/src/system/generic/system_impl.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -0,0 +1,31 @@
+(* Unison file synchronizer: src/system/generic/system_impl.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/>.
+*)
+
+module System = System_generic
+module Fs = struct
+ include System_generic
+
+ let canSetTime win f =
+ not win ||
+ try
+ Unix.access f [Unix.W_OK];
+ true
+ with
+ Unix.Unix_error _ -> false
+
+ let setUnicodeEncoding _ = ()
+end
Copied: trunk/src/system/system_generic.ml (from rev 331, trunk/src/system_generic.ml)
===================================================================
--- trunk/src/system/system_generic.ml (rev 0)
+++ trunk/src/system/system_generic.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -0,0 +1,63 @@
+(* Unison file synchronizer: src/system/system_generic.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 fspath = string
+
+let fspathFromString f = f
+let fspathToPrintString f = f
+let fspathToString f = f
+let fspathToDebugString f = String.escaped f
+
+let fspathConcat = Filename.concat
+let fspathDirname = Filename.dirname
+let fspathAddSuffixToFinalName f suffix = f ^ suffix
+
+(****)
+
+let getenv = Sys.getenv
+let putenv = Unix.putenv
+let argv () = Sys.argv
+
+(****)
+
+type dir_handle = Unix.dir_handle
+
+let stat = Unix.LargeFile.stat
+let lstat = Unix.LargeFile.lstat
+let rmdir = Unix.rmdir
+let mkdir = Unix.mkdir
+let unlink = Unix.unlink
+let rename = Unix.rename
+let open_in_gen = open_in_gen
+let open_out_gen = open_out_gen
+let chmod = Unix.chmod
+let chown = Unix.chown
+let utimes = Unix.utimes
+let link = Unix.link
+let openfile = Unix.openfile
+let opendir = Unix.opendir
+let readdir = Unix.readdir
+let closedir = Unix.closedir
+let readlink = Unix.readlink
+let symlink = Unix.symlink
+let chdir = Sys.chdir
+let getcwd = Sys.getcwd
+
+(****)
+
+let file_exists = Sys.file_exists
+let open_in_bin = open_in_bin
Copied: trunk/src/system/system_intf.ml (from rev 331, trunk/src/system_intf.ml)
===================================================================
--- trunk/src/system/system_intf.ml (rev 0)
+++ trunk/src/system/system_intf.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -0,0 +1,70 @@
+(* Unison file synchronizer: src/system/system_intf.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/>.
+*)
+
+module type Core = sig
+
+type fspath
+type dir_handle
+
+val symlink : string -> fspath -> unit
+val readlink : fspath -> string
+val chown : fspath -> int -> int -> unit
+val chmod : fspath -> int -> unit
+val utimes : fspath -> float -> float -> unit
+val unlink : fspath -> unit
+val rmdir : fspath -> unit
+val mkdir : fspath -> Unix.file_perm -> unit
+val rename : fspath -> fspath -> unit
+val stat : fspath -> Unix.LargeFile.stats
+val lstat : fspath -> Unix.LargeFile.stats
+val opendir : fspath -> dir_handle
+val readdir : dir_handle -> string
+val closedir : dir_handle -> unit
+val openfile :
+ fspath -> Unix.open_flag list -> Unix.file_perm -> Unix.file_descr
+
+(****)
+
+val open_out_gen : open_flag list -> int -> fspath -> out_channel
+val open_in_bin : fspath -> in_channel
+val file_exists : fspath -> bool
+
+end
+
+module type Full = sig
+
+include Core
+
+val putenv : string -> string -> unit
+val getenv : string -> string
+val argv : unit -> string array
+
+val fspathFromString : string -> fspath
+val fspathToPrintString : fspath -> string
+val fspathToDebugString : fspath -> string
+val fspathToString : fspath -> string
+val fspathConcat : fspath -> string -> fspath
+val fspathDirname : fspath -> fspath
+val fspathAddSuffixToFinalName : fspath -> string -> fspath
+
+val open_in_gen : open_flag list -> int -> fspath -> in_channel
+
+val link : fspath -> fspath -> unit
+val chdir : fspath -> unit
+val getcwd : unit -> fspath
+
+end
Copied: trunk/src/system/system_win.ml (from rev 331, trunk/src/system_win.ml)
===================================================================
--- trunk/src/system/system_win.ml (rev 0)
+++ trunk/src/system/system_win.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -0,0 +1,192 @@
+(* Unison file synchronizer: src/system/system_win.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/>.
+*)
+
+(*XXXX
+
+We have to propagate the encoding mode when canonizing roots
+===> new major version
+
+TO CONVERT
+==========
+Unix.open_process_in
+Unix.open_process_out
+Unix.create_process
+Unix.execvp
+Lwt_unix.open_process_full
+Lwt_unix.open_process_in
+
+- Use SetConsoleOutputCP/SetConsoleCP in text mode ???
+*)
+
+type fspath = string
+
+let fspathFromString f = f
+let fspathToPrintString f = f
+let fspathToString f = f
+let fspathToDebugString f = String.escaped f
+
+let fspathConcat = Filename.concat
+let fspathDirname = Filename.dirname
+let fspathAddSuffixToFinalName f suffix = f ^ suffix
+
+(****)
+
+let fixPath f =
+ for i = 0 to String.length f - 1 do
+ if f.[i] = '/' then f.[i] <- '\\'
+ done;
+ f
+let winRootRx = Rx.rx "[a-zA-Z]:[/\\].*"
+let winUncRx = Rx.rx "//[^/]+/[^/]+/.*"
+(* FIX: we could also handle UNC paths *)
+let extendedPath f =
+ if Rx.match_string winRootRx f then
+ fixPath ("\\\\?\\" ^ f)
+ else
+ f
+
+let utf16 s = Unicode.to_utf_16 s
+let utf8 s = Unicode.from_utf_16 s
+let path16 = utf16
+let epath f = utf16 (extendedPath f)
+
+let sys_error e =
+ match e with
+ Unix.Unix_error (err, _, "") ->
+ raise (Sys_error (Unix.error_message err))
+ | Unix.Unix_error (err, _, s) ->
+ raise (Sys_error (Format.sprintf "%s: %s" s (Unix.error_message err)))
+ | _ ->
+ raise e
+
+(****)
+
+external getenv_impl : string -> string = "win_getenv"
+external putenv_impl : string -> string -> string -> unit = "win_putenv"
+external argv_impl : unit -> string array = "win_argv"
+
+let getenv nm = utf8 (getenv_impl (utf16 nm))
+let putenv nm v = putenv_impl nm (utf16 nm) (utf16 v)
+let argv () = Array.map utf8 (argv_impl ())
+
+(****)
+
+type dir_entry = Dir_empty | Dir_read of string | Dir_toread
+type dir_handle = Unix.dir_handle
+type dir_handle' =
+ { handle : int; mutable entry_read: dir_entry }
+
+external stat_impl : string -> string -> Unix.LargeFile.stats = "win_stat"
+external rmdir_impl : string -> string -> unit = "win_rmdir"
+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 chmod_impl : string -> string -> int -> unit = "win_chmod"
+external utimes_impl :
+ string -> string -> float -> float -> unit = "win_utimes"
+external open_impl :
+ string -> string -> Unix.open_flag list -> Unix.file_perm -> Unix.file_descr = "win_open"
+external chdir_impl : string -> string -> unit = "win_chdir"
+external getcwd_impl : unit -> string = "win_getcwd"
+external findfirst : string -> string * int = "win_findfirstw"
+external findnext : int -> string = "win_findnextw"
+external findclose : int -> unit = "win_findclosew"
+
+let stat f = stat_impl f (epath f)
+let lstat = stat
+let rmdir f = rmdir_impl f (epath f)
+let mkdir f perms = mkdir_impl f (epath f)
+let unlink f = unlink_impl f (epath f)
+let rename f1 f2 = rename_impl f1 (epath f1) (epath f2)
+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 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", ""))
+
+let chdir f =
+ try
+ chdir_impl f (path16 f) (* Better not to use [epath] here *)
+ with e -> sys_error e
+let getcwd () =
+ try
+ utf8 (getcwd_impl ())
+ with e -> sys_error e
+
+let badFileRx = Rx.rx ".*[?*].*"
+
+let ud : dir_handle' -> dir_handle = Obj.magic
+let du : dir_handle -> dir_handle' = Obj.magic
+
+let opendir d =
+ if Rx.match_string badFileRx d then
+ raise (Unix.Unix_error (Unix.ENOENT, "opendir", d));
+ try
+ let (first_entry, handle) = findfirst (epath (fspathConcat d "*")) in
+ ud { handle = handle; entry_read = Dir_read first_entry }
+ with End_of_file ->
+ ud { handle = 0; entry_read = Dir_empty }
+let readdir d =
+ let d = du d in
+ match d.entry_read with
+ Dir_empty -> raise End_of_file
+ | Dir_read name -> d.entry_read <- Dir_toread; utf8 name
+ | Dir_toread -> utf8 (findnext d.handle)
+let closedir d =
+ let d = du d in
+ match d.entry_read with
+ Dir_empty -> ()
+ | _ -> findclose d.handle
+
+let rec conv_flags fl =
+ match fl with
+ Open_rdonly :: rem -> Unix.O_RDONLY :: conv_flags rem
+ | Open_wronly :: rem -> Unix.O_WRONLY :: conv_flags rem
+ | Open_append :: rem -> Unix.O_APPEND :: conv_flags rem
+ | Open_creat :: rem -> Unix.O_CREAT :: conv_flags rem
+ | Open_trunc :: rem -> Unix.O_TRUNC :: conv_flags rem
+ | Open_excl :: rem -> Unix.O_EXCL :: conv_flags rem
+ | Open_binary :: rem -> conv_flags rem
+ | Open_text :: rem -> conv_flags rem
+ | Open_nonblock :: rem -> Unix.O_NONBLOCK :: conv_flags rem
+ | [] -> []
+
+let open_in_gen flags perms f =
+ try
+ Unix.in_channel_of_descr (openfile f (conv_flags flags) perms)
+ with e ->
+ sys_error e
+let open_out_gen flags perms f =
+ try
+ Unix.out_channel_of_descr (openfile f (conv_flags flags) perms)
+ with e ->
+ sys_error e
+
+(****)
+
+let file_exists f =
+ try
+ ignore (stat f); true
+ with
+ Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
+ false
+ | e ->
+ sys_error e
+
+let open_in_bin f = open_in_gen [Open_rdonly; Open_binary] 0 f
Copied: trunk/src/system/system_win_stubs.c (from rev 331, trunk/src/system_win_stubs.c)
===================================================================
--- trunk/src/system/system_win_stubs.c (rev 0)
+++ trunk/src/system/system_win_stubs.c 2009-05-15 14:34:43 UTC (rev 333)
@@ -0,0 +1,430 @@
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+
+#define _WIN32_WINDOWS 0x0410
+
+#include <wtypes.h>
+#include <winbase.h>
+#include <fcntl.h>
+#include <io.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <share.h>
+#include <errno.h>
+#include <utime.h>
+#include <wchar.h>
+#include <stddef.h>
+#include <stdlib.h>
+#include <time.h>
+#include <ctype.h>
+#include <direct.h>
+#include <stdio.h>
+#include <windows.h>
+
+#define Nothing ((value) 0)
+
+struct filedescr {
+ union {
+ HANDLE handle;
+ SOCKET socket;
+ } fd;
+ enum { KIND_HANDLE, KIND_SOCKET } kind;
+ int crt_fd;
+};
+#define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle)
+
+static value copy_wstring(LPCWSTR s)
+{
+ int len;
+ value res;
+
+ len = 2 * wcslen(s) + 2; /* NULL character included */
+ res = caml_alloc_string(len);
+ memmove(String_val(res), s, len);
+ return res;
+}
+
+extern void win32_maperr (DWORD errcode);
+extern void uerror (char * cmdname, value arg);
+extern value win_alloc_handle (HANDLE h);
+extern value cst_to_constr (int n, int * tbl, int size, int deflt);
+
+static int open_access_flags[12] = {
+ GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0
+};
+
+static int open_create_flags[12] = {
+ 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0
+};
+
+static int open_flag_table[12] = {
+ _O_RDONLY, _O_WRONLY, _O_RDWR, 0, _O_APPEND, _O_CREAT, _O_TRUNC,
+ _O_EXCL, 0, 0, 0, 0
+};
+
+/****/
+
+CAMLprim value win_rmdir(value path, value wpath)
+{
+ CAMLparam2(path, wpath);
+ if (!RemoveDirectoryW((LPWSTR)String_val(wpath))) {
+ win32_maperr (GetLastError ());
+ uerror("rmdir", path);
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_mkdir(value path, value wpath)
+{
+ CAMLparam2(path, wpath);
+ if (!CreateDirectoryW((LPWSTR)String_val(wpath), NULL)) {
+ win32_maperr (GetLastError ());
+ uerror("mkdir", path);
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_unlink(value path, value wpath)
+{
+ CAMLparam2(path, wpath);
+ if (!DeleteFileW((LPWSTR)String_val(wpath))) {
+ win32_maperr (GetLastError ());
+ uerror("unlink", path);
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_rename(value path1, value wpath1, value wpath2)
+{
+ CAMLparam3(path1, wpath1, wpath2);
+ if (!MoveFileExW((LPWSTR)String_val(wpath1), (LPWSTR)String_val(wpath2),
+ MOVEFILE_REPLACE_EXISTING)) {
+ 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);
+
+ attr = GetFileAttributesW ((LPCWSTR)String_val (wpath));
+ if (attr == INVALID_FILE_ATTRIBUTES) {
+ win32_maperr (GetLastError ());
+ uerror("chmod", path);
+ }
+ if (Int_val(perm) & _S_IWRITE)
+ attr &= ~FILE_ATTRIBUTE_READONLY;
+ else
+ attr |= FILE_ATTRIBUTE_READONLY;
+
+ if (!SetFileAttributesW ((LPCWSTR)String_val (wpath), attr)) {
+ win32_maperr (GetLastError ());
+ uerror("chmod", path);
+ }
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_utimes (value path, value wpath, value atime, value mtime) {
+ HANDLE h;
+ BOOL res;
+ ULARGE_INTEGER iatime, imtime;
+ FILETIME fatime, fmtime;
+
+ CAMLparam4(path, wpath, atime, mtime);
+
+ iatime.QuadPart = Double_val(atime);
+ imtime.QuadPart = Double_val(mtime);
+
+ /* http://www.filewatcher.com/p/Win32-UTCFileTime-1.44.tar.gz.93147/Win32-UTCFileTime-1.44/UTCFileTime.xs.html */
+ /* http://savannah.nongnu.org/bugs/?22781#comment0 */
+ if (iatime.QuadPart || imtime.QuadPart) {
+ iatime.QuadPart += 11644473600ull;
+ iatime.QuadPart *= 10000000ull;
+ fatime.dwLowDateTime = iatime.LowPart;
+ fatime.dwHighDateTime = iatime.HighPart;
+ imtime.QuadPart += 11644473600ull;
+ imtime.QuadPart *= 10000000ull;
+ fmtime.dwLowDateTime = imtime.LowPart;
+ fmtime.dwHighDateTime = imtime.HighPart;
+ } else {
+ GetSystemTimeAsFileTime (&fatime);
+ fmtime = fatime;
+ }
+ h = CreateFileW ((LPWSTR) wpath, FILE_WRITE_ATTRIBUTES,
+ FILE_SHARE_READ | FILE_SHARE_WRITE,
+ NULL, OPEN_EXISTING, 0, NULL);
+ if (h == INVALID_HANDLE_VALUE) {
+ win32_maperr (GetLastError ());
+ uerror("utimes", path);
+ }
+ res = SetFileTime (h, NULL, &fatime, &fmtime);
+ if (res == 0) {
+ win32_maperr (GetLastError ());
+ (void)CloseHandle (h);
+ uerror("utimes", path);
+ }
+ res = CloseHandle (h);
+ if (res == 0) {
+ win32_maperr (GetLastError ());
+ uerror("utimes", path);
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_open (value path, value wpath, value flags, value perm) {
+ int fileaccess, createflags, fileattrib, filecreate;
+ SECURITY_ATTRIBUTES attr;
+ HANDLE h;
+
+ CAMLparam4 (path, wpath, flags, perm);
+
+ fileaccess = convert_flag_list(flags, open_access_flags);
+
+ createflags = convert_flag_list(flags, open_create_flags);
+ if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
+ filecreate = CREATE_NEW;
+ else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC))
+ filecreate = CREATE_ALWAYS;
+ else if (createflags & O_TRUNC)
+ filecreate = TRUNCATE_EXISTING;
+ else if (createflags & O_CREAT)
+ filecreate = OPEN_ALWAYS;
+ else
+ filecreate = OPEN_EXISTING;
+
+ if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0)
+ fileattrib = FILE_ATTRIBUTE_READONLY;
+ else
+ fileattrib = FILE_ATTRIBUTE_NORMAL;
+
+ attr.nLength = sizeof(attr);
+ attr.lpSecurityDescriptor = NULL;
+ attr.bInheritHandle = TRUE;
+
+ h = CreateFileW((LPCWSTR) String_val(wpath), fileaccess,
+ FILE_SHARE_READ | FILE_SHARE_WRITE, &attr,
+ filecreate, fileattrib, NULL);
+
+ if (h == INVALID_HANDLE_VALUE) {
+ win32_maperr (GetLastError ());
+ uerror("open", path);
+ }
+
+ CAMLreturn(win_alloc_handle(h));
+}
+
+#define MAKEDWORDLONG(a,b) ((DWORDLONG)(((DWORD)(a))|(((DWORDLONG)((DWORD)(b)))<<32)))
+#define FILETIME_TO_TIME(ft) (((((ULONGLONG) ft.dwHighDateTime) << 32) + ft.dwLowDateTime) / 10000000ull - 11644473600ull)
+
+CAMLprim value win_stat(value path, value wpath)
+{
+ int res, mode;
+ HANDLE h;
+ BY_HANDLE_FILE_INFORMATION info;
+ CAMLparam2(path,wpath);
+ CAMLlocal1 (v);
+
+ h = CreateFileW ((LPCWSTR) String_val (wpath), 0, 0, NULL, OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY, NULL);
+
+ if (h == INVALID_HANDLE_VALUE) {
+ win32_maperr (GetLastError ());
+ uerror("stat", path);
+ }
+
+ res = GetFileInformationByHandle (h, &info);
+ if (res == 0) {
+ win32_maperr (GetLastError ());
+ (void) CloseHandle (h);
+ uerror("stat", path);
+ }
+
+ res = CloseHandle (h);
+ if (res == 0) {
+ win32_maperr (GetLastError ());
+ uerror("stat", path);
+ }
+
+ v = caml_alloc (12, 0);
+ Store_field (v, 0, Val_int (info.dwVolumeSerialNumber));
+ Store_field
+ (v, 1, Val_int (MAKEDWORDLONG(info.nFileIndexLow,info.nFileIndexHigh)));
+ Store_field
+ (v, 2, Val_int (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY
+ ? 1: 0));
+ mode = 0000444;
+ if (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
+ mode |= 0000111;
+ if (!(info.dwFileAttributes & FILE_ATTRIBUTE_READONLY))
+ mode |= 0000222;
+ Store_field (v, 3, Val_int(mode));
+ Store_field (v, 4, Val_int (1));
+ Store_field (v, 5, Val_int (0));
+ Store_field (v, 6, Val_int (0));
+ Store_field (v, 7, Val_int (0));
+ Store_field
+ (v, 8, copy_int64(MAKEDWORDLONG(info.nFileSizeLow,info.nFileSizeHigh)));
+ Store_field
+ (v, 9, copy_double((double) FILETIME_TO_TIME(info.ftLastAccessTime)));
+ Store_field
+ (v, 10, copy_double((double) FILETIME_TO_TIME(info.ftLastWriteTime)));
+ Store_field
+ (v, 11, copy_double((double) FILETIME_TO_TIME(info.ftCreationTime)));
+
+ CAMLreturn (v);
+}
+
+CAMLprim value win_chdir (value path, value wpath)
+{
+ CAMLparam2(path,wpath);
+ if (!SetCurrentDirectoryW ((LPWSTR)wpath)) {
+ win32_maperr(GetLastError());
+ uerror("chdir", path);
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_getcwd (value unit)
+{
+ int res;
+ LPWSTR s;
+ CAMLparam0();
+ CAMLlocal1 (path);
+
+ s = stat_alloc (32768 * 2);
+ res = GetCurrentDirectoryW (32768, s);
+ if (res == 0) {
+ stat_free (s);
+ win32_maperr(GetLastError());
+ uerror("getcwd", Nothing);
+ }
+ /* Normalize the path */
+ res = GetLongPathNameW (s, s, 32768);
+ if (res == 0) {
+ stat_free (s);
+ win32_maperr(GetLastError());
+ uerror("getcwd", Nothing);
+ }
+ /* Convert the drive letter to uppercase */
+ if (s[0] >= L'a' && s[0] <= L'z') s[0] -= 32;
+ path = copy_wstring(s);
+ stat_free (s);
+ CAMLreturn (path);
+}
+
+CAMLprim value win_findfirstw(value name)
+{
+ HANDLE h;
+ WIN32_FIND_DATAW fileinfo;
+
+ CAMLparam1(name);
+ CAMLlocal3(v, valname, valh);
+
+ h = FindFirstFileW((LPCWSTR) String_val(name),&fileinfo);
+ if (h == INVALID_HANDLE_VALUE) {
+ DWORD err = GetLastError();
+ if (err == ERROR_NO_MORE_FILES)
+ raise_end_of_file();
+ else {
+ win32_maperr(err);
+ uerror("opendir", Nothing);
+ }
+ }
+ valname = copy_wstring(fileinfo.cFileName);
+ valh = win_alloc_handle(h);
+ v = alloc_small(2, 0);
+ Field(v,0) = valname;
+ Field(v,1) = valh;
+ CAMLreturn (v);
+}
+
+CAMLprim value win_findnextw(value valh)
+{
+ WIN32_FIND_DATAW fileinfo;
+ BOOL retcode;
+
+ CAMLparam1(valh);
+
+ retcode = FindNextFileW(Handle_val(valh), &fileinfo);
+ if (!retcode) {
+ DWORD err = GetLastError();
+ if (err == ERROR_NO_MORE_FILES)
+ raise_end_of_file();
+ else {
+ win32_maperr(err);
+ uerror("readdir", Nothing);
+ }
+ }
+ CAMLreturn (copy_wstring(fileinfo.cFileName));
+}
+
+CAMLprim value win_findclosew(value valh)
+{
+ CAMLparam1(valh);
+
+ if (! FindClose(Handle_val(valh))) {
+ win32_maperr(GetLastError());
+ uerror("closedir", Nothing);
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_getenv(value var)
+{
+ LPWSTR s;
+ DWORD len;
+ CAMLparam1(var);
+ CAMLlocal1(res);
+
+ s = stat_alloc (65536);
+
+ len = GetEnvironmentVariableW((LPCWSTR) String_val(var), s, 65536);
+ if (len == 0) { stat_free (s); raise_not_found(); }
+
+ res = copy_wstring(s);
+ stat_free (s);
+ CAMLreturn (res);
+
+}
+
+CAMLprim value win_putenv(value var, value wvar, value v)
+{
+ BOOL res;
+ CAMLparam3(var, wvar, v);
+
+ res = SetEnvironmentVariableW((LPCWSTR) String_val(wvar), (LPCWSTR) v);
+ if (res == 0) {
+ win32_maperr (GetLastError ());
+ uerror("putenv", var);
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_argv(value unit)
+{
+ int n, i;
+ LPWSTR * l;
+
+ CAMLparam0();
+ CAMLlocal2(v,res);
+
+ l = CommandLineToArgvW (GetCommandLineW (), &n);
+
+ if (l == NULL) {
+ win32_maperr (GetLastError ());
+ uerror("argv", Nothing);
+ }
+ res = caml_alloc (n, 0);
+ for (i = 0; i < n; i++) {
+ v = copy_wstring (l[i]);
+ Store_field (res, i, v);
+ }
+ LocalFree (l);
+ CAMLreturn (res);
+}
Added: trunk/src/system/win/system_impl.ml
===================================================================
--- trunk/src/system/win/system_impl.ml (rev 0)
+++ trunk/src/system/win/system_impl.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -0,0 +1,63 @@
+(* Unison file synchronizer: src/system/win/system_impl.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/>.
+*)
+
+module System = System_win
+
+module Fs = struct
+ (* The new implementation of utimes does not have the limitation of
+ the standard one *)
+ let canSetTime win f = true
+
+ let unicode = ref false
+
+ let setUnicodeEncoding u = unicode := u
+
+ let c1 f1 f2 v1 = if !unicode then f1 v1 else f2 v1
+ let c2 f1 f2 v1 v2 = if !unicode then f1 v1 v2 else f2 v1 v2
+ let c3 f1 f2 v1 v2 v3 = if !unicode then f1 v1 v2 v3 else f2 v1 v2 v3
+
+ module G = System_generic
+ module W = System_win
+
+ type fspath = string
+
+ let fspathConcat v1 v2 = c2 W.fspathConcat G.fspathConcat v1 v2
+ let fspathDirname v = c1 W.fspathDirname G.fspathDirname v
+
+ type dir_handle = Unix.dir_handle
+
+ let symlink v1 v2 = c2 W.symlink G.symlink v1 v2
+ let readlink v = c1 W.readlink G.readlink v
+ let chown v1 v2 v3 = c3 W.chown G.chown v1 v2 v3
+ let chmod v1 v2 = c2 W.chmod G.chmod v1 v2
+ let utimes v1 v2 v3 = c3 W.utimes G.utimes v1 v2 v3
+ let unlink v = c1 W.unlink G.unlink v
+ let rmdir v = c1 W.rmdir G.rmdir v
+ let mkdir v1 v2 = c2 W.mkdir G.mkdir v1 v2
+ let rename v1 v2 = c2 W.rename G.rename v1 v2
+ let stat v = c1 W.stat G.stat v
+ let lstat v = c1 W.lstat G.lstat v
+ let opendir v = c1 W.opendir G.opendir v
+ let readdir v = c1 W.readdir G.readdir v
+ let closedir v = c1 W.closedir G.closedir v
+ let openfile v1 v2 v3 = c3 W.openfile G.openfile v1 v2 v3
+ let open_in_gen v1 v2 v3 = c3 W.open_in_gen G.open_in_gen v1 v2 v3
+ let open_out_gen v1 v2 v3 = c3 W.open_out_gen G.open_out_gen v1 v2 v3
+ let getcwd v = c1 W.getcwd G.getcwd v
+ let chdir v = c1 W.chdir G.chdir v
+ let readlink v = c1 W.readlink G.readlink v
+end
Deleted: trunk/src/system.ml
===================================================================
--- trunk/src/system.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/system.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,19 +0,0 @@
-(* Unison file synchronizer: src/system.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/>.
-*)
-
-include System_generic
-(*include System_win*)
Added: trunk/src/system.ml
===================================================================
--- trunk/src/system.ml (rev 0)
+++ trunk/src/system.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -0,0 +1,18 @@
+(* Unison file synchronizer: src/system.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/>.
+*)
+
+include System_impl.System
Deleted: trunk/src/system_generic.ml
===================================================================
--- trunk/src/system_generic.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/system_generic.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,63 +0,0 @@
-(* Unison file synchronizer: src/system_generic.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 fspath = string
-
-let fspathFromString f = f
-let fspathToPrintString f = f
-let fspathToString f = f
-let fspathToDebugString f = String.escaped f
-
-let fspathConcat = Filename.concat
-let fspathDirname = Filename.dirname
-let fspathAddSuffixToFinalName f suffix = f ^ suffix
-
-(****)
-
-let getenv = Sys.getenv
-let putenv = Unix.putenv
-let argv () = Sys.argv
-
-(****)
-
-type dir_handle = Unix.dir_handle
-
-let stat = Unix.LargeFile.stat
-let lstat = Unix.LargeFile.lstat
-let rmdir = Unix.rmdir
-let mkdir = Unix.mkdir
-let unlink = Unix.unlink
-let rename = Unix.rename
-let open_in_gen = open_in_gen
-let open_out_gen = open_out_gen
-let chmod = Unix.chmod
-let chown = Unix.chown
-let utimes = Unix.utimes
-let link = Unix.link
-let openfile = Unix.openfile
-let opendir = Unix.opendir
-let readdir = Unix.readdir
-let closedir = Unix.closedir
-let readlink = Unix.readlink
-let symlink = Unix.symlink
-let chdir = Sys.chdir
-let getcwd = Sys.getcwd
-
-(****)
-
-let file_exists = Sys.file_exists
-let open_in_bin = open_in_bin
Deleted: trunk/src/system_intf.ml
===================================================================
--- trunk/src/system_intf.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/system_intf.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,70 +0,0 @@
-(* Unison file synchronizer: src/system_intf.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/>.
-*)
-
-module type Core = sig
-
-type fspath
-type dir_handle
-
-val symlink : string -> fspath -> unit
-val readlink : fspath -> string
-val chown : fspath -> int -> int -> unit
-val chmod : fspath -> int -> unit
-val utimes : fspath -> float -> float -> unit
-val unlink : fspath -> unit
-val rmdir : fspath -> unit
-val mkdir : fspath -> Unix.file_perm -> unit
-val rename : fspath -> fspath -> unit
-val stat : fspath -> Unix.LargeFile.stats
-val lstat : fspath -> Unix.LargeFile.stats
-val opendir : fspath -> dir_handle
-val readdir : dir_handle -> string
-val closedir : dir_handle -> unit
-val openfile :
- fspath -> Unix.open_flag list -> Unix.file_perm -> Unix.file_descr
-
-(****)
-
-val open_out_gen : open_flag list -> int -> fspath -> out_channel
-val open_in_bin : fspath -> in_channel
-val file_exists : fspath -> bool
-
-end
-
-module type Full = sig
-
-include Core
-
-val putenv : string -> string -> unit
-val getenv : string -> string
-val argv : unit -> string array
-
-val fspathFromString : string -> fspath
-val fspathToPrintString : fspath -> string
-val fspathToDebugString : fspath -> string
-val fspathToString : fspath -> string
-val fspathConcat : fspath -> string -> fspath
-val fspathDirname : fspath -> fspath
-val fspathAddSuffixToFinalName : fspath -> string -> fspath
-
-val open_in_gen : open_flag list -> int -> fspath -> in_channel
-
-val link : fspath -> fspath -> unit
-val chdir : fspath -> unit
-val getcwd : unit -> fspath
-
-end
Deleted: trunk/src/system_win.ml
===================================================================
--- trunk/src/system_win.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/system_win.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,194 +0,0 @@
-(* Unison file synchronizer: src/system_win.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/>.
-*)
-
-(*XXXX
-Compilation/configuration issues
-
-Adapt fspath.ml to use Unix rather than Sys variants of getcwd and chdir?
-
-XXX Do not forget operations in fspath.ml...
-
-We have to propagate the encoding mode when canonizing roots
-===> new major version
-
-TO CONVERT
-==========
-Unix.open_process_in
-Unix.open_process_out
-Unix.create_process
-Unix.execvp
-Lwt_unix.open_process_full
-Lwt_unix.open_process_in
-
-- Try to hide the console when not using ssh
-- Use SetConsoleOutputCP/SetConsoleCP in text mode
-
-copy icons to 2.32 ?
-*)
-
-type fspath = string
-
-let fspathFromString f = f
-let fspathToPrintString f = f
-let fspathToString f = f
-let fspathToDebugString f = String.escaped f
-
-let fspathConcat = Filename.concat
-let fspathDirname = Filename.dirname
-let fspathAddSuffixToFinalName f suffix = f ^ suffix
-
-(****)
-
-let fixPath f =
- for i = 0 to String.length f - 1 do
- if f.[i] = '/' then f.[i] <- '\\'
- done;
- f
-let winRootRx = Rx.rx "[a-zA-Z]:[/\\].*"
-let winUncRx = Rx.rx "//[^/]+/[^/]+/.*"
-(* FIX: we could also handle UNC paths *)
-let extendedPath f =
- if Rx.match_string winRootRx f then
- fixPath ("\\\\?\\" ^ f)
- else
- f
-
-let utf16 s = Unicode.to_utf_16 s
-let utf8 s = Unicode.from_utf_16 s
-let path16 = utf16
-let epath f = utf16 (extendedPath f)
-
-let sys_error e =
- match e with
- Unix.Unix_error (err, _, "") ->
- raise (Sys_error (Unix.error_message err))
- | Unix.Unix_error (err, _, s) ->
- raise (Sys_error (Format.sprintf "%s: %s" s (Unix.error_message err)))
- | _ ->
- raise e
-
-(****)
-
-external getenv_impl : string -> string = "win_getenv"
-external putenv_impl : string -> string -> string -> unit = "win_putenv"
-external argv_impl : unit -> string array = "win_argv"
-
-let getenv nm = utf8 (getenv_impl (utf16 nm))
-let putenv nm v = putenv_impl nm (utf16 nm) (utf16 v)
-let argv () = Array.map utf8 (argv_impl ())
-
-(****)
-
-type dir_entry = Dir_empty | Dir_read of string | Dir_toread
-type dir_handle =
- { handle : int; mutable entry_read: dir_entry }
-
-external stat_impl : string -> string -> Unix.LargeFile.stats = "win_stat"
-external rmdir_impl : string -> string -> unit = "win_rmdir"
-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 chmod_impl : string -> string -> int -> unit = "win_chmod"
-external utimes_impl :
- string -> string -> float -> float -> unit = "win_utimes"
-external open_impl :
- string -> string -> Unix.open_flag list -> Unix.file_perm -> Unix.file_descr = "win_open"
-external chdir_impl : string -> string -> unit = "win_chdir"
-external getcwd_impl : unit -> string = "win_getcwd"
-external findfirst : string -> string * int = "win_findfirstw"
-external findnext : int -> string = "win_findnextw"
-external findclose : int -> unit = "win_findclosew"
-
-let stat f = stat_impl f (epath f)
-let lstat = stat
-let rmdir f = rmdir_impl f (epath f)
-let mkdir f perms = mkdir_impl f (epath f)
-let unlink f = unlink_impl f (epath f)
-let rename f1 f2 = rename_impl f1 (epath f1) (epath f2)
-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 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", ""))
-
-let chdir f =
- try
- chdir_impl f (path16 f) (* Better not to use [epath] here *)
- with e -> sys_error e
-let getcwd () =
- try
- utf8 (getcwd_impl ())
- with e -> sys_error e
-
-let badFileRx = Rx.rx ".*[?*].*"
-
-let opendir d =
- if Rx.match_string badFileRx d then
- raise (Unix.Unix_error (Unix.ENOENT, "opendir", d));
- try
- let (first_entry, handle) = findfirst (epath (fspathConcat d "*")) in
- { handle = handle; entry_read = Dir_read first_entry }
- with End_of_file ->
- { handle = 0; entry_read = Dir_empty }
-let readdir d =
- match d.entry_read with
- Dir_empty -> raise End_of_file
- | Dir_read name -> d.entry_read <- Dir_toread; utf8 name
- | Dir_toread -> utf8 (findnext d.handle)
-let closedir d =
- match d.entry_read with
- Dir_empty -> ()
- | _ -> findclose d.handle
-
-let rec conv_flags fl =
- match fl with
- Open_rdonly :: rem -> Unix.O_RDONLY :: conv_flags rem
- | Open_wronly :: rem -> Unix.O_WRONLY :: conv_flags rem
- | Open_append :: rem -> Unix.O_APPEND :: conv_flags rem
- | Open_creat :: rem -> Unix.O_CREAT :: conv_flags rem
- | Open_trunc :: rem -> Unix.O_TRUNC :: conv_flags rem
- | Open_excl :: rem -> Unix.O_EXCL :: conv_flags rem
- | Open_binary :: rem -> conv_flags rem
- | Open_text :: rem -> conv_flags rem
- | Open_nonblock :: rem -> Unix.O_NONBLOCK :: conv_flags rem
- | [] -> []
-
-let open_in_gen flags perms f =
- try
- Unix.in_channel_of_descr (openfile f (conv_flags flags) perms)
- with e ->
- sys_error e
-let open_out_gen flags perms f =
- try
- Unix.out_channel_of_descr (openfile f (conv_flags flags) perms)
- with e ->
- sys_error e
-
-(****)
-
-let file_exists f =
- try
- ignore (stat f); true
- with
- Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
- false
- | e ->
- sys_error e
-
-let open_in_bin f = open_in_gen [Open_rdonly; Open_binary] 0 f
Deleted: trunk/src/system_win_stubs.c
===================================================================
--- trunk/src/system_win_stubs.c 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/system_win_stubs.c 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,464 +0,0 @@
-#include <caml/mlvalues.h>
-#include <caml/alloc.h>
-#include <caml/memory.h>
-#include <caml/fail.h>
-
-#include <wtypes.h>
-#include <winbase.h>
-#include <fcntl.h>
-#include <io.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <share.h>
-#include <errno.h>
-#include <utime.h>
-#include <wchar.h>
-#include <stddef.h>
-#include <stdlib.h>
-#include <time.h>
-#include <ctype.h>
-#include <direct.h>
-#include <stdio.h>
-#include <windows.h>
-
-#define Nothing ((value) 0)
-
-struct filedescr {
- union {
- HANDLE handle;
- SOCKET socket;
- } fd;
- enum { KIND_HANDLE, KIND_SOCKET } kind;
- int crt_fd;
-};
-#define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle)
-
-static value copy_wstring(LPCWSTR s)
-{
- int len;
- value res;
-
- len = 2 * wcslen(s) + 2; /* NULL character included */
- res = caml_alloc_string(len);
- memmove(String_val(res), s, len);
- return res;
-}
-
-extern void win32_maperr (DWORD errcode);
-extern void uerror (char * cmdname, value arg);
-extern value win_alloc_handle (HANDLE h);
-extern value cst_to_constr (int n, int * tbl, int size, int deflt);
-
-static int open_access_flags[12] = {
- GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
- 0, 0, 0, 0, 0, 0, 0, 0, 0
-};
-
-static int open_create_flags[12] = {
- 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0
-};
-
-static int open_flag_table[12] = {
- _O_RDONLY, _O_WRONLY, _O_RDWR, 0, _O_APPEND, _O_CREAT, _O_TRUNC,
- _O_EXCL, 0, 0, 0, 0
-};
-
-/****/
-
-CAMLprim value win_rmdir(value path, value wpath)
-{
- CAMLparam2(path, wpath);
- if (!RemoveDirectoryW((LPWSTR)String_val(wpath))) {
- win32_maperr (GetLastError ());
- uerror("rmdir", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_mkdir(value path, value wpath)
-{
- CAMLparam2(path, wpath);
- if (!CreateDirectoryW((LPWSTR)String_val(wpath), NULL)) {
- win32_maperr (GetLastError ());
- uerror("mkdir", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_unlink(value path, value wpath)
-{
- CAMLparam2(path, wpath);
- if (!DeleteFileW((LPWSTR)String_val(wpath))) {
- win32_maperr (GetLastError ());
- uerror("unlink", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_rename(value path1, value wpath1, value wpath2)
-{
- CAMLparam3(path1, wpath1, wpath2);
- if (!MoveFileExW((LPWSTR)String_val(wpath1), (LPWSTR)String_val(wpath2),
- MOVEFILE_REPLACE_EXISTING)) {
- 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);
-
- attr = GetFileAttributesW ((LPCWSTR)String_val (wpath));
- if (attr == INVALID_FILE_ATTRIBUTES) {
- win32_maperr (GetLastError ());
- uerror("chmod", path);
- }
- if (Int_val(perm) & _S_IWRITE)
- attr &= ~FILE_ATTRIBUTE_READONLY;
- else
- attr |= FILE_ATTRIBUTE_READONLY;
-
- if (!SetFileAttributesW ((LPCWSTR)String_val (wpath), attr)) {
- win32_maperr (GetLastError ());
- uerror("chmod", path);
- }
-
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_utimes (value path, value wpath, value atime, value mtime) {
- HANDLE h;
- BOOL res;
- ULARGE_INTEGER iatime, imtime;
- FILETIME fatime, fmtime;
-
- CAMLparam4(path, wpath, atime, mtime);
-
- iatime.QuadPart = Double_val(atime);
- imtime.QuadPart = Double_val(mtime);
-
- /* http://www.filewatcher.com/p/Win32-UTCFileTime-1.44.tar.gz.93147/Win32-UTCFileTime-1.44/UTCFileTime.xs.html */
- /* http://savannah.nongnu.org/bugs/?22781#comment0 */
- if (iatime.QuadPart || imtime.QuadPart) {
- iatime.QuadPart += 11644473600ull;
- iatime.QuadPart *= 10000000ull;
- fatime.dwLowDateTime = iatime.LowPart;
- fatime.dwHighDateTime = iatime.HighPart;
- imtime.QuadPart += 11644473600ull;
- imtime.QuadPart *= 10000000ull;
- fmtime.dwLowDateTime = imtime.LowPart;
- fmtime.dwHighDateTime = imtime.HighPart;
- } else {
- GetSystemTimeAsFileTime (&fatime);
- fmtime = fatime;
- }
- h = CreateFileW ((LPWSTR) wpath, FILE_WRITE_ATTRIBUTES,
- FILE_SHARE_READ | FILE_SHARE_WRITE,
- NULL, OPEN_EXISTING, 0, NULL);
- if (h == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror("utimes", path);
- }
- res = SetFileTime (h, NULL, &fatime, &fmtime);
- if (res == 0) {
- win32_maperr (GetLastError ());
- (void)CloseHandle (h);
- uerror("utimes", path);
- }
- res = CloseHandle (h);
- if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("utimes", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_open (value path, value wpath, value flags, value perm) {
- int fileaccess, createflags, fileattrib, filecreate;
- SECURITY_ATTRIBUTES attr;
- HANDLE h;
-
- CAMLparam4 (path, wpath, flags, perm);
-
- fileaccess = convert_flag_list(flags, open_access_flags);
-
- createflags = convert_flag_list(flags, open_create_flags);
- if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
- filecreate = CREATE_NEW;
- else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC))
- filecreate = CREATE_ALWAYS;
- else if (createflags & O_TRUNC)
- filecreate = TRUNCATE_EXISTING;
- else if (createflags & O_CREAT)
- filecreate = OPEN_ALWAYS;
- else
- filecreate = OPEN_EXISTING;
-
- if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0)
- fileattrib = FILE_ATTRIBUTE_READONLY;
- else
- fileattrib = FILE_ATTRIBUTE_NORMAL;
-
- attr.nLength = sizeof(attr);
- attr.lpSecurityDescriptor = NULL;
- attr.bInheritHandle = TRUE;
-
- h = CreateFileW((LPCWSTR) String_val(wpath), fileaccess,
- FILE_SHARE_READ | FILE_SHARE_WRITE, &attr,
- filecreate, fileattrib, NULL);
-
- if (h == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror("open", path);
- }
-
- CAMLreturn(win_alloc_handle(h));
-}
-
-/*
-static int file_kind_table[] = {
- S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, 0, S_IFIFO, 0
-};
-
-static value stat_aux(int use_64, struct _stati64 *buf)
-{
- CAMLparam0 ();
- CAMLlocal1 (v);
-
- v = caml_alloc (12, 0);
- Store_field (v, 0, Val_int (buf->st_dev));
- Store_field (v, 1, Val_int (buf->st_ino));
- Store_field (v, 2, cst_to_constr (buf->st_mode & S_IFMT, file_kind_table,
- sizeof(file_kind_table) / sizeof(int), 0));
- Store_field (v, 3, Val_int(buf->st_mode & 07777));
- Store_field (v, 4, Val_int (buf->st_nlink));
- Store_field (v, 5, Val_int (buf->st_uid));
- Store_field (v, 6, Val_int (buf->st_gid));
- Store_field (v, 7, Val_int (buf->st_rdev));
- Store_field (v, 8,
- use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size));
- Store_field (v, 9, copy_double((double) buf->st_atime));
- Store_field (v, 10, copy_double((double) buf->st_mtime));
- Store_field (v, 11, copy_double((double) buf->st_ctime));
- CAMLreturn (v);
-}
-*/
-#define MAKEDWORDLONG(a,b) ((DWORDLONG)(((DWORD)(a))|(((DWORDLONG)((DWORD)(b)))<<32)))
-#define FILETIME_TO_TIME(ft) (((((ULONGLONG) ft.dwHighDateTime) << 32) + ft.dwLowDateTime) / 10000000ull - 11644473600ull)
-
-CAMLprim value win_stat(value path, value wpath)
-{
- int res, mode;
- HANDLE h;
- BY_HANDLE_FILE_INFORMATION info;
- CAMLparam2(path,wpath);
- CAMLlocal1 (v);
-
- h = CreateFileW ((LPCWSTR) String_val (wpath), 0, 0, NULL, OPEN_EXISTING,
- FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY, NULL);
-
- if (h == INVALID_HANDLE_VALUE) {
- win32_maperr (GetLastError ());
- uerror("stat", path);
- }
-
- res = GetFileInformationByHandle (h, &info);
- if (res == 0) {
- win32_maperr (GetLastError ());
- (void) CloseHandle (h);
- uerror("stat", path);
- }
-
- res = CloseHandle (h);
- if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("stat", path);
- }
-
- v = caml_alloc (12, 0);
- Store_field (v, 0, Val_int (info.dwVolumeSerialNumber));
- Store_field
- (v, 1, Val_int (MAKEDWORDLONG(info.nFileIndexLow,info.nFileIndexHigh)));
- Store_field
- (v, 2, Val_int (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY
- ? 1: 0));
- mode = 0000444;
- if (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
- mode |= 0000111;
- if (!(info.dwFileAttributes & FILE_ATTRIBUTE_READONLY))
- mode |= 0000222;
- Store_field (v, 3, Val_int(mode));
- Store_field (v, 4, Val_int (1));
- Store_field (v, 5, Val_int (0));
- Store_field (v, 6, Val_int (0));
- Store_field (v, 7, Val_int (0));
- Store_field
- (v, 8, copy_int64(MAKEDWORDLONG(info.nFileSizeLow,info.nFileSizeHigh)));
- Store_field
- (v, 9, copy_double((double) FILETIME_TO_TIME(info.ftLastAccessTime)));
- Store_field
- (v, 10, copy_double((double) FILETIME_TO_TIME(info.ftLastWriteTime)));
- Store_field
- (v, 11, copy_double((double) FILETIME_TO_TIME(info.ftCreationTime)));
-
- CAMLreturn (v);
-}
-
-/*
-CAMLprim value win_stat(value path, value wpath)
-{
- CAMLparam2(path,wpath);
- int ret;
- struct _stati64 buf;
- ret = _wstati64((const wchar_t *)String_val(wpath), &buf);
- if (ret == -1) uerror("stat", path);
- CAMLreturn(stat_aux(1, &buf));
-}
-*/
-
-CAMLprim value win_chdir (value path, value wpath)
-{
- CAMLparam2(path,wpath);
- if (!SetCurrentDirectoryW ((LPWSTR)wpath)) {
- win32_maperr(GetLastError());
- uerror("chdir", path);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_getcwd (value unit)
-{
- int len;
- LPWSTR s;
- CAMLparam0();
- CAMLlocal1 (res);
-
- len = GetCurrentDirectoryW (0, NULL);
- if (len == 0) {
- win32_maperr(GetLastError());
- uerror("getcwd", Nothing);
- }
- s = stat_alloc (len * 2 + 2);
- len = GetCurrentDirectoryW (len, s);
- if (len == 0) {
- stat_free (s);
- win32_maperr(GetLastError());
- uerror("getcwd", Nothing);
- }
- res = copy_wstring(s);
- stat_free (s);
- CAMLreturn (res);
-}
-
-CAMLprim value win_findfirstw(value name)
-{
- HANDLE h;
- WIN32_FIND_DATAW fileinfo;
-
- CAMLparam1(name);
- CAMLlocal3(v, valname, valh);
-
- h = FindFirstFileW((LPCWSTR) String_val(name),&fileinfo);
- if (h == INVALID_HANDLE_VALUE) {
- DWORD err = GetLastError();
- if (err == ERROR_NO_MORE_FILES)
- raise_end_of_file();
- else {
- win32_maperr(err);
- uerror("opendir", Nothing);
- }
- }
- valname = copy_wstring(fileinfo.cFileName);
- valh = win_alloc_handle(h);
- v = alloc_small(2, 0);
- Field(v,0) = valname;
- Field(v,1) = valh;
- CAMLreturn (v);
-}
-
-CAMLprim value win_findnextw(value valh)
-{
- WIN32_FIND_DATAW fileinfo;
- BOOL retcode;
-
- CAMLparam1(valh);
-
- retcode = FindNextFileW(Handle_val(valh), &fileinfo);
- if (!retcode) {
- DWORD err = GetLastError();
- if (err == ERROR_NO_MORE_FILES)
- raise_end_of_file();
- else {
- win32_maperr(err);
- uerror("readdir", Nothing);
- }
- }
- CAMLreturn (copy_wstring(fileinfo.cFileName));
-}
-
-CAMLprim value win_findclosew(value valh)
-{
- CAMLparam1(valh);
-
- if (! FindClose(Handle_val(valh))) {
- win32_maperr(GetLastError());
- uerror("closedir", Nothing);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_getenv(value var)
-{
- LPWSTR s;
- DWORD len;
- CAMLparam1(var);
- CAMLlocal1(res);
-
- s = stat_alloc (65536);
-
- len = GetEnvironmentVariableW((LPCWSTR) String_val(var), s, 65536);
- if (len == 0) { stat_free (s); raise_not_found(); }
-
- res = copy_wstring(s);
- stat_free (s);
- CAMLreturn (res);
-
-}
-
-CAMLprim value win_putenv(value var, value wvar, value v)
-{
- BOOL res;
- CAMLparam3(var, wvar, v);
-
- res = SetEnvironmentVariableW((LPCWSTR) String_val(wvar), (LPCWSTR) v);
- if (res == 0) {
- win32_maperr (GetLastError ());
- uerror("putenv", var);
- }
- CAMLreturn (Val_unit);
-}
-
-CAMLprim value win_argv(value unit)
-{
- int n, i;
- LPWSTR * l;
-
- CAMLparam0();
- CAMLlocal2(v,res);
-
- l = CommandLineToArgvW (GetCommandLineW (), &n);
-
- if (l == NULL) {
- win32_maperr (GetLastError ());
- uerror("argv", Nothing);
- }
- res = caml_alloc (n, 0);
- for (i = 0; i < n; i++) {
- v = copy_wstring (l[i]);
- Store_field (res, i, v);
- }
- LocalFree (l);
- CAMLreturn (res);
-}
Modified: trunk/src/terminal.ml
===================================================================
--- trunk/src/terminal.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/terminal.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -1,3 +1,20 @@
+(* Unison file synchronizer: src/terminal.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/>.
+*)
+
(* Parsing messages from OpenSSH *)
(* Examples.
Modified: trunk/src/ubase/depend
===================================================================
--- trunk/src/ubase/depend 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/ubase/depend 2009-05-15 14:34:43 UTC (rev 333)
@@ -2,8 +2,6 @@
myMap.cmx: myMap.cmi
prefs.cmo: util.cmi uarg.cmi safelist.cmi prefs.cmi
prefs.cmx: util.cmx uarg.cmx safelist.cmx prefs.cmi
-projectInfo.cmo:
-projectInfo.cmx:
rx.cmo: rx.cmi
rx.cmx: rx.cmi
safelist.cmo: safelist.cmi
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2009-05-14 15:59:33 UTC (rev 332)
+++ trunk/src/uigtk2.ml 2009-05-15 14:34:43 UTC (rev 333)
@@ -1463,8 +1463,10 @@
)
| None, _ ->
(false, true, false) in
- grSet grAction activate1;
- grSet grDiff activate2;
+ if not !busy then begin
+ grSet grAction activate1;
+ grSet grDiff activate2
+ end;
if details then
showDetailsButton#misc#show ()
else
More information about the Unison-hackers
mailing list