[Unison-hackers] [unison-svn] r331 - in trunk/src: . lwt ubase
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Wed May 13 14:02:39 EDT 2009
Author: vouillon
Date: 2009-05-13 14:02:17 -0400 (Wed, 13 May 2009)
New Revision: 331
Added:
trunk/src/fs.ml
trunk/src/fs.mli
trunk/src/system.ml
trunk/src/system.mli
trunk/src/system_generic.ml
trunk/src/system_intf.ml
trunk/src/system_win.ml
trunk/src/system_win_stubs.c
Removed:
trunk/src/linktk.ml
Modified:
trunk/src/.depend
trunk/src/Makefile.OCaml
trunk/src/RECENTNEWS
trunk/src/case.mli
trunk/src/common.ml
trunk/src/copy.ml
trunk/src/fileinfo.ml
trunk/src/fileinfo.mli
trunk/src/files.ml
trunk/src/files.mli
trunk/src/fingerprint.ml
trunk/src/fingerprint.mli
trunk/src/fspath.ml
trunk/src/fspath.mli
trunk/src/lock.ml
trunk/src/lock.mli
trunk/src/lwt/lwt_unix.ml
trunk/src/main.ml
trunk/src/mkProjectInfo.ml
trunk/src/os.ml
trunk/src/os.mli
trunk/src/osx.ml
trunk/src/osx.mli
trunk/src/props.ml
trunk/src/remote.ml
trunk/src/stasher.ml
trunk/src/test.ml
trunk/src/ubase/prefs.ml
trunk/src/ubase/prefs.mli
trunk/src/ubase/trace.ml
trunk/src/ubase/uarg.ml
trunk/src/ubase/util.ml
trunk/src/ubase/util.mli
trunk/src/uicommon.ml
trunk/src/uigtk.ml
trunk/src/uigtk2.ml
trunk/src/uimacbridge.ml
trunk/src/uimacbridgenew.ml
trunk/src/uitext.ml
trunk/src/unicode.ml
trunk/src/unicode.mli
trunk/src/update.ml
trunk/src/uutil.ml
trunk/src/uutil.mli
trunk/src/xferhint.ml
Log:
* Added an abstraction layer over Unix/Sys modules in order to be able
to redefine all system calls involving filenames
* Implemented corresponding bindings for the Windows Unicode API
(not activated by default yet)
* Uses improved emulation of "select" call provided by Ocaml 3.11
under Windows (the GUI should not freeze as much during synchronization)
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/.depend 2009-05-13 18:02:17 UTC (rev 331)
@@ -1,5 +1,5 @@
abort.cmi: uutil.cmi
-case.cmi:
+case.cmi: ubase/prefs.cmi
checksum.cmi:
clroot.cmi:
common.cmi: uutil.cmi props.cmi path.cmi osx.cmi os.cmi name.cmi fspath.cmi \
@@ -7,16 +7,17 @@
copy.cmi: uutil.cmi props.cmi path.cmi osx.cmi os.cmi lwt/lwt.cmi fspath.cmi \
common.cmi
external.cmi:
-fileinfo.cmi: props.cmi path.cmi osx.cmi fspath.cmi
-files.cmi: uutil.cmi props.cmi path.cmi lwt/lwt_util.cmi lwt/lwt.cmi \
- common.cmi
+fileinfo.cmi: system.cmi props.cmi path.cmi osx.cmi fspath.cmi
+files.cmi: uutil.cmi system.cmi props.cmi path.cmi lwt/lwt_util.cmi \
+ lwt/lwt.cmi common.cmi
fileutil.cmi:
fingerprint.cmi: uutil.cmi path.cmi fspath.cmi
-fspath.cmi: path.cmi name.cmi
+fs.cmi: 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:
+lock.cmi: system.cmi
name.cmi:
-os.cmi: props.cmi path.cmi name.cmi fspath.cmi fileinfo.cmi
+os.cmi: system.cmi props.cmi path.cmi name.cmi fspath.cmi fileinfo.cmi
osx.cmi: uutil.cmi ubase/prefs.cmi path.cmi fspath.cmi fingerprint.cmi
path.cmi: name.cmi
pred.cmi:
@@ -26,6 +27,7 @@
sortri.cmi: common.cmi
stasher.cmi: ubase/prefs.cmi path.cmi os.cmi fspath.cmi
strings.cmi:
+system.cmi: system_intf.cmo
terminal.cmi:
test.cmi:
transfer.cmi: uutil.cmi lwt/lwt.cmi
@@ -57,38 +59,40 @@
osx.cmx os.cmx name.cmx fspath.cmx fileinfo.cmx common.cmi
copy.cmo: xferhint.cmi uutil.cmi ubase/util.cmi transfer.cmi ubase/trace.cmi \
ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi \
- os.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi fspath.cmi fileinfo.cmi \
- external.cmi common.cmi clroot.cmi abort.cmi copy.cmi
+ os.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi fspath.cmi fs.cmi \
+ fileinfo.cmi external.cmi common.cmi clroot.cmi abort.cmi copy.cmi
copy.cmx: xferhint.cmx uutil.cmx ubase/util.cmx transfer.cmx ubase/trace.cmx \
ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx \
- os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx fspath.cmx fileinfo.cmx \
- external.cmx common.cmx clroot.cmx abort.cmx copy.cmi
+ os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx \
+ fileinfo.cmx external.cmx common.cmx clroot.cmx abort.cmx copy.cmi
external.cmo: ubase/util.cmi ubase/safelist.cmi lwt/lwt_util.cmi \
lwt/lwt_unix.cmi lwt/lwt.cmi external.cmi
external.cmx: ubase/util.cmx ubase/safelist.cmx lwt/lwt_util.cmx \
lwt/lwt_unix.cmx lwt/lwt.cmx external.cmi
-fileinfo.cmo: ubase/util.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi \
- fspath.cmi fileinfo.cmi
-fileinfo.cmx: ubase/util.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx \
- fspath.cmx fileinfo.cmi
-files.cmo: uutil.cmi ubase/util.cmi update.cmi ubase/trace.cmi stasher.cmi \
- ubase/safelist.cmi ubase/rx.cmi remote.cmi props.cmi ubase/prefs.cmi \
- path.cmi osx.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
- globals.cmi fspath.cmi fingerprint.cmi fileinfo.cmi external.cmi copy.cmi \
- common.cmi abort.cmi files.cmi
-files.cmx: uutil.cmx ubase/util.cmx update.cmx ubase/trace.cmx stasher.cmx \
- ubase/safelist.cmx ubase/rx.cmx remote.cmx props.cmx ubase/prefs.cmx \
- path.cmx osx.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
- globals.cmx fspath.cmx fingerprint.cmx fileinfo.cmx external.cmx copy.cmx \
- common.cmx abort.cmx files.cmi
+fileinfo.cmo: ubase/util.cmi system.cmi props.cmi ubase/prefs.cmi path.cmi \
+ osx.cmi fspath.cmi fs.cmi fileinfo.cmi
+fileinfo.cmx: ubase/util.cmx system.cmx props.cmx ubase/prefs.cmx path.cmx \
+ osx.cmx fspath.cmx fs.cmx fileinfo.cmi
+files.cmo: uutil.cmi ubase/util.cmi update.cmi ubase/trace.cmi system.cmi \
+ stasher.cmi ubase/safelist.cmi ubase/rx.cmi remote.cmi props.cmi \
+ ubase/prefs.cmi path.cmi osx.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi \
+ lwt/lwt.cmi globals.cmi fspath.cmi fs.cmi fingerprint.cmi fileinfo.cmi \
+ external.cmi copy.cmi common.cmi abort.cmi files.cmi
+files.cmx: uutil.cmx ubase/util.cmx update.cmx ubase/trace.cmx system.cmx \
+ stasher.cmx ubase/safelist.cmx ubase/rx.cmx remote.cmx props.cmx \
+ ubase/prefs.cmx path.cmx osx.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx \
+ lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx fingerprint.cmx fileinfo.cmx \
+ external.cmx copy.cmx common.cmx abort.cmx files.cmi
fileutil.cmo: fileutil.cmi
fileutil.cmx: fileutil.cmi
-fingerprint.cmo: uutil.cmi ubase/util.cmi fspath.cmi fingerprint.cmi
-fingerprint.cmx: uutil.cmx ubase/util.cmx fspath.cmx fingerprint.cmi
-fspath.cmo: ubase/util.cmi ubase/rx.cmi path.cmi name.cmi fileutil.cmi \
- fspath.cmi
-fspath.cmx: ubase/util.cmx ubase/rx.cmx path.cmx name.cmx fileutil.cmx \
- fspath.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
+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 \
+ name.cmx fileutil.cmx fspath.cmi
globals.cmo: ubase/util.cmi ubase/trace.cmi ubase/safelist.cmi remote.cmi \
ubase/prefs.cmi pred.cmi path.cmi os.cmi name.cmi lwt/lwt_util.cmi \
lwt/lwt_unix.cmi lwt/lwt.cmi common.cmi clroot.cmi globals.cmi
@@ -101,26 +105,28 @@
linkgtk.cmx: uigtk.cmx main.cmx
linktext.cmo: uitext.cmi main.cmo
linktext.cmx: uitext.cmx main.cmx
-linktk.cmo: main.cmo
-linktk.cmx: main.cmx
-lock.cmo: ubase/util.cmi lock.cmi
-lock.cmx: ubase/util.cmx lock.cmi
+lock.cmo: ubase/util.cmi system.cmi lock.cmi
+lock.cmx: ubase/util.cmx system.cmx lock.cmi
main.cmo: uutil.cmi ubase/util.cmi uitext.cmi uicommon.cmi strings.cmi \
- ubase/safelist.cmi remote.cmi ubase/prefs.cmi os.cmi fspath.cmi
+ ubase/safelist.cmi remote.cmi ubase/prefs.cmi os.cmi
main.cmx: uutil.cmx ubase/util.cmx uitext.cmx uicommon.cmx strings.cmx \
- ubase/safelist.cmx remote.cmx ubase/prefs.cmx os.cmx fspath.cmx
+ ubase/safelist.cmx remote.cmx ubase/prefs.cmx os.cmx
mkProjectInfo.cmo:
mkProjectInfo.cmx:
name.cmo: ubase/util.cmi ubase/rx.cmi case.cmi name.cmi
name.cmx: ubase/util.cmx ubase/rx.cmx case.cmx name.cmi
-os.cmo: uutil.cmi ubase/util.cmi ubase/safelist.cmi props.cmi ubase/prefs.cmi \
- path.cmi osx.cmi name.cmi fspath.cmi fingerprint.cmi fileinfo.cmi os.cmi
-os.cmx: uutil.cmx ubase/util.cmx ubase/safelist.cmx props.cmx ubase/prefs.cmx \
- path.cmx osx.cmx name.cmx fspath.cmx fingerprint.cmx fileinfo.cmx os.cmi
-osx.cmo: uutil.cmi ubase/util.cmi ubase/safelist.cmi ubase/prefs.cmi path.cmi \
- name.cmi fspath.cmi fingerprint.cmi osx.cmi
-osx.cmx: uutil.cmx ubase/util.cmx ubase/safelist.cmx ubase/prefs.cmx path.cmx \
- name.cmx fspath.cmx fingerprint.cmx osx.cmi
+os.cmo: uutil.cmi ubase/util.cmi system.cmi ubase/safelist.cmi props.cmi \
+ ubase/prefs.cmi path.cmi osx.cmi name.cmi fspath.cmi fs.cmi \
+ fingerprint.cmi fileinfo.cmi os.cmi
+os.cmx: uutil.cmx ubase/util.cmx system.cmx ubase/safelist.cmx props.cmx \
+ ubase/prefs.cmx path.cmx osx.cmx name.cmx fspath.cmx fs.cmx \
+ fingerprint.cmx fileinfo.cmx os.cmi
+osx.cmo: uutil.cmi ubase/util.cmi system.cmi ubase/safelist.cmi \
+ ubase/prefs.cmi path.cmi name.cmi fspath.cmi fs.cmi fingerprint.cmi \
+ osx.cmi
+osx.cmx: uutil.cmx ubase/util.cmx system.cmx ubase/safelist.cmx \
+ ubase/prefs.cmx path.cmx name.cmx fspath.cmx fs.cmx fingerprint.cmx \
+ osx.cmi
path.cmo: ubase/util.cmi ubase/safelist.cmi ubase/rx.cmi pred.cmi name.cmi \
fileutil.cmi case.cmi path.cmi
path.cmx: ubase/util.cmx ubase/safelist.cmx ubase/rx.cmx pred.cmx name.cmx \
@@ -132,35 +138,43 @@
pred.cmx: ubase/util.cmx ubase/safelist.cmx ubase/rx.cmx ubase/prefs.cmx \
case.cmx pred.cmi
props.cmo: uutil.cmi ubase/util.cmi ubase/prefs.cmi path.cmi osx.cmi \
- fspath.cmi external.cmi props.cmi
+ fspath.cmi fs.cmi external.cmi props.cmi
props.cmx: uutil.cmx ubase/util.cmx ubase/prefs.cmx path.cmx osx.cmx \
- fspath.cmx external.cmx props.cmi
+ fspath.cmx fs.cmx external.cmx props.cmi
recon.cmo: ubase/util.cmi update.cmi tree.cmi ubase/trace.cmi sortri.cmi \
ubase/safelist.cmi props.cmi ubase/prefs.cmi pred.cmi path.cmi name.cmi \
globals.cmi fileinfo.cmi common.cmi recon.cmi
recon.cmx: ubase/util.cmx update.cmx tree.cmx ubase/trace.cmx sortri.cmx \
ubase/safelist.cmx props.cmx ubase/prefs.cmx pred.cmx path.cmx name.cmx \
globals.cmx fileinfo.cmx common.cmx recon.cmi
-remote.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi terminal.cmi \
+remote.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi terminal.cmi system.cmi \
ubase/safelist.cmi ubase/prefs.cmi os.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
fspath.cmi common.cmi clroot.cmi remote.cmi
-remote.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx terminal.cmx \
+remote.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx terminal.cmx system.cmx \
ubase/safelist.cmx ubase/prefs.cmx os.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
fspath.cmx common.cmx clroot.cmx remote.cmi
sortri.cmo: ubase/util.cmi ubase/safelist.cmi ubase/prefs.cmi pred.cmi \
path.cmi common.cmi sortri.cmi
sortri.cmx: ubase/util.cmx ubase/safelist.cmx ubase/prefs.cmx pred.cmx \
path.cmx common.cmx sortri.cmi
-stasher.cmo: ubase/util.cmi ubase/safelist.cmi remote.cmi props.cmi \
- ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi lwt/lwt_unix.cmi \
- lwt/lwt.cmi globals.cmi fspath.cmi fingerprint.cmi fileutil.cmi \
- fileinfo.cmi copy.cmi common.cmi stasher.cmi
-stasher.cmx: ubase/util.cmx ubase/safelist.cmx remote.cmx props.cmx \
- ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx lwt/lwt_unix.cmx \
- lwt/lwt.cmx globals.cmx fspath.cmx fingerprint.cmx fileutil.cmx \
- fileinfo.cmx copy.cmx common.cmx stasher.cmi
+stasher.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi remote.cmi \
+ props.cmi ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi \
+ lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi fingerprint.cmi \
+ fileutil.cmi fileinfo.cmi copy.cmi common.cmi stasher.cmi
+stasher.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx remote.cmx \
+ props.cmx ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx \
+ lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx fingerprint.cmx \
+ 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
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 \
@@ -168,11 +182,13 @@
test.cmo: uutil.cmi ubase/util.cmi update.cmi uicommon.cmi transport.cmi \
ubase/trace.cmi stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi \
ubase/prefs.cmi path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi \
- lwt/lwt.cmi globals.cmi fspath.cmi fingerprint.cmi common.cmi test.cmi
+ lwt/lwt.cmi globals.cmi fspath.cmi fs.cmi fingerprint.cmi common.cmi \
+ test.cmi
test.cmx: uutil.cmx ubase/util.cmx update.cmx uicommon.cmx transport.cmx \
ubase/trace.cmx stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx \
ubase/prefs.cmx path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx \
- lwt/lwt.cmx globals.cmx fspath.cmx fingerprint.cmx common.cmx test.cmi
+ lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx fingerprint.cmx common.cmx \
+ test.cmi
transfer.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi ubase/safelist.cmi \
lwt/lwt.cmi checksum.cmi transfer.cmi
transfer.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx ubase/safelist.cmx \
@@ -188,76 +204,76 @@
tree.cmo: ubase/safelist.cmi tree.cmi
tree.cmx: ubase/safelist.cmx tree.cmi
uicommon.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi \
- ubase/trace.cmi stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi \
- props.cmi ubase/prefs.cmi path.cmi osx.cmi os.cmi name.cmi \
+ ubase/trace.cmi system.cmi stasher.cmi ubase/safelist.cmi remote.cmi \
+ recon.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi os.cmi name.cmi \
lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi files.cmi \
fileinfo.cmi common.cmi clroot.cmi case.cmi uicommon.cmi
uicommon.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx \
- ubase/trace.cmx stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx \
- props.cmx ubase/prefs.cmx path.cmx osx.cmx os.cmx name.cmx \
+ ubase/trace.cmx system.cmx stasher.cmx ubase/safelist.cmx remote.cmx \
+ recon.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx os.cmx name.cmx \
lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx files.cmx \
fileinfo.cmx common.cmx clroot.cmx case.cmx uicommon.cmi
uigtk2.cmo: uutil.cmi ubase/util.cmi update.cmi uitext.cmi uicommon.cmi \
- transport.cmi ubase/trace.cmi strings.cmi sortri.cmi ubase/safelist.cmi \
- remote.cmi recon.cmi ubase/prefs.cmi pixmaps.cmo path.cmi os.cmi \
- lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi \
- files.cmi common.cmi clroot.cmi uigtk2.cmi
+ transport.cmi ubase/trace.cmi system.cmi strings.cmi sortri.cmi \
+ ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi pixmaps.cmo \
+ path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi \
+ files.cmi common.cmi clroot.cmi case.cmi uigtk2.cmi
uigtk2.cmx: uutil.cmx ubase/util.cmx update.cmx uitext.cmx uicommon.cmx \
- transport.cmx ubase/trace.cmx strings.cmx sortri.cmx ubase/safelist.cmx \
- remote.cmx recon.cmx ubase/prefs.cmx pixmaps.cmx path.cmx os.cmx \
- lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx \
- files.cmx common.cmx clroot.cmx uigtk2.cmi
+ transport.cmx ubase/trace.cmx system.cmx strings.cmx sortri.cmx \
+ ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx pixmaps.cmx \
+ path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx \
+ files.cmx common.cmx clroot.cmx case.cmx uigtk2.cmi
uigtk.cmo: uutil.cmi ubase/util.cmi update.cmi uitext.cmi uicommon.cmi \
- transport.cmi ubase/trace.cmi strings.cmi sortri.cmi ubase/safelist.cmi \
- remote.cmi recon.cmi ubase/prefs.cmi pixmaps.cmo path.cmi os.cmi \
- lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi \
+ transport.cmi ubase/trace.cmi system.cmi strings.cmi sortri.cmi \
+ ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi pixmaps.cmo \
+ path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi \
files.cmi common.cmi clroot.cmi uigtk.cmi
uigtk.cmx: uutil.cmx ubase/util.cmx update.cmx uitext.cmx uicommon.cmx \
- transport.cmx ubase/trace.cmx strings.cmx sortri.cmx ubase/safelist.cmx \
- remote.cmx recon.cmx ubase/prefs.cmx pixmaps.cmx path.cmx os.cmx \
- lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx \
+ transport.cmx ubase/trace.cmx system.cmx strings.cmx sortri.cmx \
+ ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx pixmaps.cmx \
+ path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx \
files.cmx common.cmx clroot.cmx uigtk.cmi
uimacbridge.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi \
- uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi stasher.cmi \
- ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi path.cmi os.cmi \
- main.cmo lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi \
- fspath.cmi files.cmi common.cmi clroot.cmi
+ uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi system.cmi \
+ stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi \
+ path.cmi os.cmi main.cmo lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
+ globals.cmi fspath.cmi files.cmi common.cmi clroot.cmi
uimacbridge.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx \
- uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx stasher.cmx \
- ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx path.cmx os.cmx \
- main.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx \
- fspath.cmx files.cmx common.cmx clroot.cmx
+ uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx system.cmx \
+ stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx \
+ path.cmx os.cmx main.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
+ globals.cmx fspath.cmx files.cmx common.cmx clroot.cmx
uimacbridgenew.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi \
- uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi stasher.cmi \
- ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi path.cmi os.cmi \
- main.cmo lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi \
- fspath.cmi files.cmi common.cmi clroot.cmi
+ uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi system.cmi \
+ stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi \
+ path.cmi os.cmi main.cmo lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
+ globals.cmi fspath.cmi files.cmi common.cmi clroot.cmi
uimacbridgenew.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx \
- uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx stasher.cmx \
- ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx path.cmx os.cmx \
- main.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx \
- fspath.cmx files.cmx common.cmx clroot.cmx
+ uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx system.cmx \
+ stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx \
+ path.cmx os.cmx main.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
+ globals.cmx fspath.cmx files.cmx common.cmx clroot.cmx
uitext.cmo: uutil.cmi ubase/util.cmi update.cmi uicommon.cmi transport.cmi \
- ubase/trace.cmi ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi \
- path.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi \
- common.cmi uitext.cmi
+ ubase/trace.cmi system.cmi ubase/safelist.cmi remote.cmi recon.cmi \
+ ubase/prefs.cmi path.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
+ globals.cmi common.cmi uitext.cmi
uitext.cmx: uutil.cmx ubase/util.cmx update.cmx uicommon.cmx transport.cmx \
- ubase/trace.cmx ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx \
- path.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx \
- common.cmx uitext.cmi
+ ubase/trace.cmx system.cmx ubase/safelist.cmx remote.cmx recon.cmx \
+ ubase/prefs.cmx path.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
+ globals.cmx common.cmx uitext.cmi
unicode.cmo: unicode_tables.cmo unicode.cmi
unicode.cmx: unicode_tables.cmx unicode.cmi
unicode_tables.cmo:
unicode_tables.cmx:
update.cmo: xferhint.cmi uutil.cmi ubase/util.cmi tree.cmi ubase/trace.cmi \
- stasher.cmi ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi \
- pred.cmi path.cmi osx.cmi os.cmi name.cmi ubase/myMap.cmi \
- lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi globals.cmi fspath.cmi \
+ system.cmi stasher.cmi ubase/safelist.cmi remote.cmi props.cmi \
+ ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi name.cmi ubase/myMap.cmi \
+ lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi globals.cmi fspath.cmi fs.cmi \
fingerprint.cmi fileinfo.cmi external.cmi common.cmi update.cmi
update.cmx: xferhint.cmx uutil.cmx ubase/util.cmx tree.cmx ubase/trace.cmx \
- stasher.cmx ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx \
- pred.cmx path.cmx osx.cmx os.cmx name.cmx ubase/myMap.cmx \
- lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx globals.cmx fspath.cmx \
+ system.cmx stasher.cmx ubase/safelist.cmx remote.cmx props.cmx \
+ ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx name.cmx ubase/myMap.cmx \
+ lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx globals.cmx fspath.cmx fs.cmx \
fingerprint.cmx fileinfo.cmx external.cmx common.cmx update.cmi
uutil.cmo: ubase/util.cmi ubase/projectInfo.cmo uutil.cmi
uutil.cmx: ubase/util.cmx ubase/projectInfo.cmx uutil.cmi
@@ -275,9 +291,9 @@
lwt/pqueue.cmx: lwt/pqueue.cmi
ubase/myMap.cmo: ubase/myMap.cmi
ubase/myMap.cmx: ubase/myMap.cmi
-ubase/prefs.cmo: ubase/util.cmi ubase/uarg.cmi ubase/safelist.cmi \
+ubase/prefs.cmo: ubase/util.cmi ubase/uarg.cmi system.cmi ubase/safelist.cmi \
ubase/prefs.cmi
-ubase/prefs.cmx: ubase/util.cmx ubase/uarg.cmx ubase/safelist.cmx \
+ubase/prefs.cmx: ubase/util.cmx ubase/uarg.cmx system.cmx ubase/safelist.cmx \
ubase/prefs.cmi
ubase/projectInfo.cmo:
ubase/projectInfo.cmx:
@@ -285,25 +301,27 @@
ubase/rx.cmx: ubase/rx.cmi
ubase/safelist.cmo: ubase/safelist.cmi
ubase/safelist.cmx: ubase/safelist.cmi
-ubase/trace.cmo: ubase/util.cmi ubase/safelist.cmi ubase/prefs.cmi \
+ubase/trace.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi ubase/prefs.cmi \
ubase/trace.cmi
-ubase/trace.cmx: ubase/util.cmx ubase/safelist.cmx ubase/prefs.cmx \
+ubase/trace.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx ubase/prefs.cmx \
ubase/trace.cmi
-ubase/uarg.cmo: ubase/util.cmi ubase/safelist.cmi ubase/uarg.cmi
-ubase/uarg.cmx: ubase/util.cmx ubase/safelist.cmx ubase/uarg.cmi
+ubase/uarg.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi ubase/uarg.cmi
+ubase/uarg.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx ubase/uarg.cmi
ubase/uprintf.cmo: ubase/uprintf.cmi
ubase/uprintf.cmx: ubase/uprintf.cmi
-ubase/util.cmo: ubase/uprintf.cmi ubase/safelist.cmi ubase/util.cmi
-ubase/util.cmx: ubase/uprintf.cmx ubase/safelist.cmx ubase/util.cmi
+ubase/util.cmo: ubase/uprintf.cmi system.cmi ubase/safelist.cmi \
+ ubase/util.cmi
+ubase/util.cmx: ubase/uprintf.cmx system.cmx ubase/safelist.cmx \
+ ubase/util.cmi
lwt/lwt.cmi:
lwt/lwt_unix.cmi: lwt/lwt.cmi
lwt/lwt_util.cmi: lwt/lwt.cmi
lwt/pqueue.cmi:
ubase/myMap.cmi:
-ubase/prefs.cmi: ubase/util.cmi
+ubase/prefs.cmi: ubase/util.cmi system.cmi
ubase/rx.cmi:
ubase/safelist.cmi:
ubase/trace.cmi: ubase/prefs.cmi
ubase/uarg.cmi:
ubase/uprintf.cmi:
-ubase/util.cmi:
+ubase/util.cmi: system.cmi
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/Makefile.OCaml 2009-05-13 18:02:17 UTC (rev 331)
@@ -98,6 +98,8 @@
# issue."
# CLIBS+=-cclib win32rc/unison.res
# STATICLIBS+=-cclib win32rc/unison.res
+ COBJS+=system_win_stubs$(OBJ_EXT)
+ WINOBJS=system_win.cmo
CLIBS+=-cclib "-link win32rc/unison.res"
STATICLIBS+=-cclib "-link win32rc/unison.res"
buildexecutable::
@@ -108,6 +110,8 @@
ifeq ($(OSARCH),win32gnuc)
CWD=.
EXEC_EXT=.exe
+ COBJS+=system_win_stubs$(OBJ_EXT)
+ WINOBJS=system_win.cmo
CLIBS+=-cclib win32rc/unison.res.lib
STATIC=false # Cygwin is not MinGW :-(
buildexecutable::
@@ -176,14 +180,19 @@
# File extensions will be substituted for the native code version
OCAMLOBJS += \
+ ubase/rx.cmo \
+ \
+ unicode_tables.cmo unicode.cmo \
+ $(WINOBJS) system_generic.cmo system.cmo \
+ \
ubase/projectInfo.cmo ubase/myMap.cmo ubase/safelist.cmo \
- ubase/uprintf.cmo ubase/util.cmo ubase/rx.cmo ubase/uarg.cmo \
+ ubase/uprintf.cmo ubase/util.cmo ubase/uarg.cmo \
ubase/prefs.cmo ubase/trace.cmo \
\
lwt/pqueue.cmo lwt/lwt.cmo lwt/lwt_util.cmo lwt/lwt_unix.cmo \
\
- unicode_tables.cmo unicode.cmo case.cmo pred.cmo uutil.cmo \
- fileutil.cmo name.cmo path.cmo fspath.cmo fingerprint.cmo \
+ case.cmo pred.cmo uutil.cmo \
+ fileutil.cmo name.cmo path.cmo fspath.cmo fs.cmo fingerprint.cmo \
abort.cmo osx.cmo external.cmo \
props.cmo fileinfo.cmo os.cmo lock.cmo clroot.cmo common.cmo \
tree.cmo checksum.cmo terminal.cmo \
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/RECENTNEWS 2009-05-13 18:02:17 UTC (rev 331)
@@ -1,5 +1,15 @@
CHANGES FROM VERSION 2.33.2
+* Added an abstraction layer over Unix/Sys modules in order to be able
+ to redefine all system calls involving filenames
+* Implemented corresponding bindings for the Windows Unicode API
+ (not activated by default yet)
+* Uses improved emulation of "select" call provided by Ocaml 3.11
+ under Windows (the GUI should not freeze as much during synchronization)
+
+-------------------------------
+CHANGES FROM VERSION 2.33.2
+
* Fixed predicate matching in Unicode case-insensitive mode
-------------------------------
Modified: trunk/src/case.mli
===================================================================
--- trunk/src/case.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/case.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -1,6 +1,8 @@
(* Unison file synchronizer: src/case.mli *)
(* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *)
+val unicodeEncoding : bool Prefs.t
+
type mode
val ops : unit ->
Modified: trunk/src/common.ml
===================================================================
--- trunk/src/common.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/common.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -38,8 +38,8 @@
let root2string root =
match root with
- (Local, fspath) -> Fspath.toString fspath
- | (Remote host, fspath) -> "//"^host^"/"^(Fspath.toString fspath)
+ (Local, fspath) -> Fspath.toPrintString fspath
+ | (Remote host, fspath) -> "//"^host^"/"^(Fspath.toPrintString fspath)
(* ------------------------------------------------------------------------- *)
(* Root comparison *)
@@ -50,7 +50,7 @@
(Local,fspath1), (Local,fspath2) ->
(* FIX: This is a path comparison, should it take case
sensitivity into account ? *)
- compare (Fspath.toString fspath1) (Fspath.toString fspath2)
+ Fspath.compare fspath1 fspath2
| (Local,_), (Remote _,_) -> -1
| (Remote _,_), (Local,_) -> 1
| (Remote host1, fspath1), (Remote host2, fspath2) ->
@@ -60,7 +60,7 @@
if result = 0 then
(* FIX: This is a path comparison, should it take case
sensitivity into account ? *)
- compare (Fspath.toString fspath1) (Fspath.toString fspath2)
+ Fspath.compare fspath1 fspath2
else
result
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/copy.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -24,30 +24,29 @@
let openFileIn fspath path kind =
match kind with
- `DATA -> open_in_gen [Open_rdonly; Open_binary] 0o444
- (Fspath.concatToString fspath path)
+ `DATA -> Fs.open_in_bin (Fspath.concat fspath path)
| `RESS _ -> Osx.openRessIn fspath path
let openFileOut fspath path kind =
match kind with
`DATA ->
- let fullpath = Fspath.concatToString fspath path in
+ let fullpath = Fspath.concat fspath path in
let flags = [Unix.O_WRONLY;Unix.O_CREAT] in
let perm = 0o600 in
begin match Util.osType with
`Win32 ->
- open_out_gen
+ Fs.open_out_gen
[Open_wronly; Open_creat; Open_excl; Open_binary] perm fullpath
| `Unix ->
let fd =
try
- Unix.openfile fullpath (Unix.O_EXCL :: flags) perm
+ Fs.openfile fullpath (Unix.O_EXCL :: flags) perm
with
Unix.Unix_error
((Unix.EOPNOTSUPP | Unix.EUNKNOWNERR 524), _, _) ->
(* O_EXCL not supported under a Netware NFS-mounted filesystem.
Solaris and Linux report different errors. *)
- Unix.openfile fullpath (Unix.O_TRUNC :: flags) perm
+ Fs.openfile fullpath (Unix.O_TRUNC :: flags) perm
in
Unix.out_channel_of_descr fd
end
@@ -83,8 +82,8 @@
use_id (fun id -> Uutil.showProgress id Uutil.Filesize.zero "l");
debug (fun () ->
Util.msg "Copy.localFile %s / %s to %s / %s\n"
- (Fspath.toString fspathFrom) (Path.toString pathFrom)
- (Fspath.toString fspathTo) (Path.toString pathTo));
+ (Fspath.toDebugString fspathFrom) (Path.toString pathFrom)
+ (Fspath.toDebugString fspathTo) (Path.toString pathTo));
let inFd = openFileIn fspathFrom pathFrom `DATA in
protect (fun () ->
Os.delete fspathTo pathTo;
@@ -333,8 +332,8 @@
connFrom fspathFrom pathFrom fspathTo pathTo realPathTo
update desc ressLength ressOnly id =
debug (fun() -> Util.msg "reallyTransferFile(%s,%s) -> (%s,%s,%s,%s)%s\n"
- (Fspath.toString fspathFrom) (Path.toString pathFrom)
- (Fspath.toString fspathTo) (Path.toString pathTo)
+ (Fspath.toDebugString fspathFrom) (Path.toString pathFrom)
+ (Fspath.toDebugString fspathTo) (Path.toString pathTo)
(Path.toString realPathTo) (Props.toString desc)
(if ressOnly then " (ONLY RESOURCE FORK)" else ""));
let srcFileSize = Props.length desc in
@@ -347,7 +346,7 @@
(* Data fork *)
if Os.exists fspathTo pathTo then begin
debug (fun() -> Util.msg "Removing old temp file %s / %s\n"
- (Fspath.toString fspathTo) (Path.toString pathTo));
+ (Fspath.toDebugString fspathTo) (Path.toString pathTo));
Os.delete fspathTo pathTo
end;
startReceivingFile
@@ -438,7 +437,7 @@
debug (fun () ->
Util.msg
"tryCopyMovedFile: found match at %s,%s. Try local copying\n"
- (Fspath.toString candidateFspath)
+ (Fspath.toDebugString candidateFspath)
(Path.toString candidatePath));
try
if Os.exists candidateFspath candidatePath then begin
@@ -562,25 +561,21 @@
Remote.registerRootCmdWithConnection "setFileinfo" setFileinfoLocal
let targetExists checkSize fspathTo pathTo =
- Os.exists fspathTo pathTo
+ let info = Fileinfo.get false fspathTo pathTo in
+ info.Fileinfo.typ = `FILE
&& (match checkSize with
`MakeWriteableAndCheckNonempty ->
- let n = Fspath.concatToString fspathTo pathTo in
- let perms = (Unix.stat n).Unix.st_perm in
+ let n = Fspath.concat fspathTo pathTo in
+ let perms = Props.perms info.Fileinfo.desc in
let perms' = perms lor 0o600 in
- Unix.chmod n perms';
- let r =
- Props.length (Fileinfo.get false fspathTo pathTo).Fileinfo.desc
- > Uutil.Filesize.zero in
- r
+ Fs.chmod n perms';
+ Props.length info.Fileinfo.desc > Uutil.Filesize.zero
| `CheckDataSize desc ->
- Props.length (Fileinfo.get false fspathTo pathTo).Fileinfo.desc
- = Props.length desc
+ Props.length info.Fileinfo.desc = Props.length desc
| `CheckSize (desc,ress) ->
- Props.length (Fileinfo.get false fspathTo pathTo).Fileinfo.desc
- = Props.length desc
- && Osx.ressLength (Osx.getFileInfos fspathTo pathTo `FILE).Osx.ressInfo
- = Osx.ressLength ress)
+ Props.length info.Fileinfo.desc = Props.length desc
+ && Osx.ressLength info.Fileinfo.osX.Osx.ressInfo =
+ Osx.ressLength ress)
let targetExistsLocal connFrom (checkSize, fspathTo, pathTo) =
Lwt.return (targetExists checkSize fspathTo pathTo)
@@ -629,16 +624,18 @@
let addquotes root s =
match root with
| Common.Local, _ -> s
- | Common.Remote _, _ -> if extraquotes then Os.quotes s else s in
+ | Common.Remote _, _ -> if extraquotes then Uutil.quotes s else s in
let fromSpec =
(formatConnectionInfo rootFrom)
- ^ (addquotes rootFrom (Fspath.concatToString (snd rootFrom) pathFrom)) in
+ ^ (addquotes rootFrom
+ (Fspath.toString (Fspath.concat (snd rootFrom) pathFrom))) in
let toSpec =
(formatConnectionInfo rootTo)
- ^ (addquotes rootTo (Fspath.concatToString fspathTo pathTo)) in
+ ^ (addquotes rootTo
+ (Fspath.toString (Fspath.concat fspathTo pathTo))) in
let cmd = prog ^ " "
- ^ (Os.quotes fromSpec) ^ " "
- ^ (Os.quotes toSpec) in
+ ^ (Uutil.quotes fromSpec) ^ " "
+ ^ (Uutil.quotes toSpec) in
Trace.log (Printf.sprintf "%s\n" cmd);
let _,log = External.runExternalProgram cmd in
debug (fun() ->
@@ -662,7 +659,7 @@
debug (fun() -> Util.msg "copyRegFile(%s,%s) -> (%s,%s,%s,%s,%s)\n"
(Common.root2string rootFrom) (Path.toString pathFrom)
(Common.root2string rootTo) (Path.toString realPathTo)
- (Fspath.toString fspathTo) (Path.toString pathTo)
+ (Fspath.toDebugString fspathTo) (Path.toString pathTo)
(Props.toString desc));
let timer = Trace.startTimer "Transmitting file" in
begin match rootFrom, rootTo with
@@ -679,7 +676,7 @@
if b then begin
Trace.log (Printf.sprintf
"%s/%s has already been transferred\n"
- (Fspath.toString fspathTo) (Path.toString pathTo));
+ (Fspath.toDebugString fspathTo) (Path.toString pathTo));
Lwt.return ()
(* Check whether we should use an external program to copy the
file *)
@@ -710,8 +707,8 @@
end else
(* Just transfer the file in the usual way with Unison's
built-in facilities *)
- transferFile
- rootFrom pathFrom rootTo fspathTo pathTo realPathTo
+ transferFile
+ rootFrom pathFrom rootTo fspathTo pathTo realPathTo
update desc fp ress false id
) end >>= (fun () ->
Trace.showTimer timer;
Modified: trunk/src/fileinfo.ml
===================================================================
--- trunk/src/fileinfo.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/fileinfo.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -32,16 +32,16 @@
(* Stat function that pays attention to pref for following links *)
let statFn fromRoot fspath path =
let fullpath = Fspath.concat fspath path in
- let stats = Fspath.lstat fullpath in
+ let stats = Fs.lstat fullpath in
if stats.Unix.LargeFile.st_kind = Unix.S_LNK
&& fromRoot
&& Path.followLink path
then
- try Fspath.stat fullpath
+ try Fs.stat fullpath
with Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) ->
raise (Util.Transient (Printf.sprintf
"Path %s is marked 'follow' but its target is missing"
- (Fspath.toString fullpath)))
+ (Fspath.toPrintString fullpath)))
else
stats
@@ -52,7 +52,8 @@
try
let stats = statFn fromRoot fspath path in
debugV (fun () ->
- Util.msg "%s: %b %f %f\n" (Fspath.concatToString fspath path)
+ Util.msg "%s: %b %f %f\n"
+ (Fspath.toDebugString (Fspath.concat fspath path))
fromRoot stats.Unix.LargeFile.st_ctime stats.Unix.LargeFile.st_mtime);
let typ =
match stats.Unix.LargeFile.st_kind with
@@ -62,7 +63,7 @@
| _ ->
raise (Util.Transient
("path " ^
- (Fspath.concatToString fspath path) ^
+ (Fspath.toPrintString (Fspath.concat fspath path)) ^
" has unknown file type"))
in
let osxInfos = Osx.getFileInfos fspath path typ in
@@ -82,7 +83,9 @@
osX = Osx.getFileInfos fspath path `ABSENT })
let check fspath path props =
- Props.check fspath path (statFn false fspath path) props
+ Util.convertUnixErrorsToTransient
+ "checking file information"
+ (fun () -> Props.check fspath path (statFn false fspath path) props)
let set fspath path action newDesc =
let (kind, p) =
@@ -159,3 +162,26 @@
(info', dataUnchanged,
Osx.ressUnchanged info.osX.Osx.ressInfo info'.osX.Osx.ressInfo
(Some t0) dataUnchanged)
+
+(****)
+
+let get' f =
+ Util.convertUnixErrorsToTransient
+ "querying file information"
+ (fun () ->
+ try
+ let stats = System.stat f in
+ let typ = `FILE in
+ let osxInfos = Osx.defaultInfos typ in
+ { typ = typ;
+ inode = stats.Unix.LargeFile.st_ino land 0x3FFFFFFF;
+ ctime = stats.Unix.LargeFile.st_ctime;
+ desc = Props.get stats osxInfos;
+ osX = osxInfos }
+ with
+ Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) ->
+ { typ = `ABSENT;
+ inode = 0;
+ ctime = 0.0;
+ desc = Props.dummy;
+ osX = Osx.defaultInfos `ABSENT })
Modified: trunk/src/fileinfo.mli
===================================================================
--- trunk/src/fileinfo.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/fileinfo.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -11,6 +11,7 @@
val set : Fspath.t -> Path.local ->
[`Set of Props.t | `Copy of Path.local | `Update of Props.t] ->
Props.t -> unit
+val get' : System.fspath -> t
(* IF THIS CHANGES, MAKE SURE TO INCREMENT THE ARCHIVE VERSION NUMBER! *)
type stamp =
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/files.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -28,15 +28,15 @@
let commitLogName = Util.fileInHomeDir "DANGER.README"
let writeCommitLog source target tempname =
- let sourcename = Fspath.toString source in
- let targetname = Fspath.toString target in
+ let sourcename = Fspath.toDebugString source in
+ let targetname = Fspath.toDebugString target in
debug (fun() -> Util.msg "Writing commit log: renaming %s to %s via %s\n"
sourcename targetname tempname);
Util.convertUnixErrorsToFatal
"writing commit log"
(fun () ->
let c =
- open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_excl]
+ System.open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_excl]
0o600 commitLogName in
Printf.fprintf c "Warning: the last run of %s terminated abnormally "
Uutil.myName;
@@ -50,16 +50,16 @@
debug (fun() -> (Util.msg "Deleting commit log\n"));
Util.convertUnixErrorsToFatal
"clearing commit log"
- (fun () -> Unix.unlink commitLogName)
+ (fun () -> System.unlink commitLogName)
let processCommitLog () =
- if Sys.file_exists commitLogName then begin
+ if System.file_exists commitLogName then begin
raise(Util.Fatal(
Printf.sprintf
"Warning: the previous run of %s terminated in a dangerous state.
Please consult the file %s, delete it, and try again."
Uutil.myName
- commitLogName))
+ (System.fspathToPrintString commitLogName)))
end else
Lwt.return ()
@@ -77,10 +77,10 @@
(* so we don't call the stasher in this case. *)
begin match workingDirOpt with
Some p ->
- debug (fun () -> Util.msg "deleteLocal [%s] (%s, %s)\n" (Fspath.toString fspath) (Fspath.toString p) (Path.toString path));
+ debug (fun () -> Util.msg "deleteLocal [%s] (%s, %s)\n" (Fspath.toDebugString fspath) (Fspath.toDebugString p) (Path.toString path));
Os.delete p path
| None ->
- debug (fun () -> Util.msg "deleteLocal [%s] (None, %s)\n" (Fspath.toString fspath) (Path.toString path));
+ debug (fun () -> Util.msg "deleteLocal [%s] (None, %s)\n" (Fspath.toDebugString fspath) (Path.toString path));
Stasher.backup fspath path `AndRemove
end;
Lwt.return ()
@@ -162,13 +162,13 @@
debug (fun () -> Util.msg "Renaming %s to %s in %s; root is %s\n"
(Path.toString pathFrom)
(Path.toString pathTo)
- (Fspath.toString fspath)
- (Fspath.toString root));
+ (Fspath.toDebugString fspath)
+ (Fspath.toDebugString root));
let source = Fspath.concat fspath pathFrom in
let target = Fspath.concat fspath pathTo in
Util.convertUnixErrorsToTransient
(Printf.sprintf "renaming %s to %s"
- (Fspath.toString source) (Fspath.toString target))
+ (Fspath.toDebugString source) (Fspath.toDebugString target))
(fun () ->
debugverbose (fun() ->
Util.msg "calling Fileinfo.get from renameLocal\n");
@@ -178,7 +178,7 @@
Util.msg "back from Fileinfo.get from renameLocal\n");
if filetypeFrom = `ABSENT then raise (Util.Transient (Printf.sprintf
"Error while renaming %s to %s -- source file has disappeared!"
- (Fspath.toString source) (Fspath.toString target)));
+ (Fspath.toPrintString source) (Fspath.toPrintString target)));
let filetypeTo =
(Fileinfo.get false target Path.empty).Fileinfo.typ in
@@ -199,9 +199,10 @@
debug (fun() -> Util.msg "rename: moveFirst=true\n");
let tmpPath = Os.tempPath fspath pathTo in
let temp = Fspath.concat fspath tmpPath in
- let temp' = Fspath.toString temp in
+ let temp' = Fspath.toDebugString temp in
- debug (fun() -> Util.msg "moving %s to %s\n" (Fspath.toString target) temp');
+ debug (fun() ->
+ Util.msg "moving %s to %s\n" (Fspath.toDebugString target) temp');
Stasher.backup root localTargetPath `ByCopying;
writeCommitLog source target temp';
Util.finalize (fun() ->
@@ -216,7 +217,8 @@
Util.convertUnixErrorsToFatal "renaming with commit log"
(fun () ->
debug (fun() -> Util.msg "rename %s to %s\n"
- (Fspath.toString source) (Fspath.toString target));
+ (Fspath.toDebugString source)
+ (Fspath.toDebugString target));
Os.rename "renameLocal(2)"
source Path.empty target Path.empty))
(fun _ -> clearCommitLog());
@@ -231,7 +233,7 @@
if filetypeFrom = `FILE then
Util.msg
"Contents of %s after renaming = %s\n"
- (Fspath.toString target)
+ (Fspath.toDebugString target)
(Fingerprint.toString (Fingerprint.file target Path.empty)));
end;
Lwt.return ())
@@ -268,7 +270,7 @@
raise (Util.Transient (Printf.sprintf
"The file %s\nhas been modified during synchronization. \
Transfer aborted."
- (Fspath.concatToString currfspath path)));
+ (Fspath.toPrintString (Fspath.concat currfspath path))));
match archStamp with
Fileinfo.InodeStamp inode
when info.Fileinfo.inode = inode
@@ -283,7 +285,7 @@
raise (Util.Transient (Printf.sprintf
"The file %s\nhas been modified during synchronization. \
Transfer aborted.%s"
- (Fspath.concatToString currfspath path)
+ (Fspath.toPrintString (Fspath.concat currfspath path))
(if Update.useFastChecking ()
&& Props.same_time info.Fileinfo.desc archDesc
then
@@ -488,12 +490,12 @@
let cmd =
if Util.findsubstring "CURRENT1" (Prefs.read diffCmd) = None then
(Prefs.read diffCmd)
- ^ " " ^ (Os.quotes (Fspath.toString fspath1))
- ^ " " ^ (Os.quotes (Fspath.toString fspath2))
+ ^ " " ^ (Fspath.quotes fspath1)
+ ^ " " ^ (Fspath.quotes fspath2)
else
Util.replacesubstrings (Prefs.read diffCmd)
- ["CURRENT1", Os.quotes (Fspath.toString fspath1);
- "CURRENT2", Os.quotes (Fspath.toString fspath2)] in
+ ["CURRENT1", Fspath.quotes fspath1;
+ "CURRENT2", Fspath.quotes fspath2] in
(* Doesn't seem to work well on Windows!
let c = Lwt_unix.run (Lwt_unix.open_process_in cmd) in *)
let c = Unix.open_process_in
@@ -559,12 +561,12 @@
(* Taken from ocamltk/jpf/fileselect.ml *)
let get_files_in_directory dir =
- let dirh = Fspath.opendir (Fspath.canonize (Some dir)) in
+ let dirh = System.opendir dir in
let files = ref [] in
begin try
- while true do files := Unix.readdir dirh :: !files done
+ while true do files := System.readdir dirh :: !files done
with End_of_file ->
- Unix.closedir dirh
+ System.closedir dirh
end;
Sort.list (<) !files
@@ -750,12 +752,12 @@
let dig2 = Os.fingerprint workingDirForMerge working2 info2 in
let cmd = formatMergeCmd
path
- (Os.quotes (Fspath.concatToString workingDirForMerge working1))
- (Os.quotes (Fspath.concatToString workingDirForMerge working2))
- (match arch with None -> None | Some f -> Some(Os.quotes (Fspath.toString f)))
- (Os.quotes (Fspath.concatToString workingDirForMerge new1))
- (Os.quotes (Fspath.concatToString workingDirForMerge new2))
- (Os.quotes (Fspath.concatToString workingDirForMerge newarch)) in
+ (Fspath.quotes (Fspath.concat workingDirForMerge working1))
+ (Fspath.quotes (Fspath.concat workingDirForMerge working2))
+ (match arch with None -> None | Some f -> Some(Fspath.quotes f))
+ (Fspath.quotes (Fspath.concat workingDirForMerge new1))
+ (Fspath.quotes (Fspath.concat workingDirForMerge new2))
+ (Fspath.quotes (Fspath.concat workingDirForMerge newarch)) in
Trace.log (Printf.sprintf "Merge command: %s\n" cmd);
let returnValue, mergeResultLog = External.runExternalProgram cmd in
@@ -782,10 +784,10 @@
(* Check which files got created by the merge command and do something appropriate
with them *)
- debug (fun()-> Util.msg "New file 1 = %s\n" (Fspath.concatToString workingDirForMerge new1));
- let new1exists = Sys.file_exists (Fspath.concatToString workingDirForMerge new1) in
- let new2exists = Sys.file_exists (Fspath.concatToString workingDirForMerge new2) in
- let newarchexists = Sys.file_exists (Fspath.concatToString workingDirForMerge newarch) in
+ debug (fun()-> Util.msg "New file 1 = %s\n" (Fspath.toDebugString (Fspath.concat workingDirForMerge new1)));
+ let new1exists = Fs.file_exists (Fspath.concat workingDirForMerge new1) in
+ let new2exists = Fs.file_exists (Fspath.concat workingDirForMerge new2) in
+ let newarchexists = Fs.file_exists (Fspath.concat workingDirForMerge newarch) in
if new1exists && new2exists then begin
if newarchexists then
@@ -828,8 +830,8 @@
else if (not new1exists) && (not new2exists) && (not newarchexists) then begin
say (fun () -> Util.msg "No outputs detected \n");
- let working1_still_exists = Sys.file_exists (Fspath.concatToString workingDirForMerge working1) in
- let working2_still_exists = Sys.file_exists (Fspath.concatToString workingDirForMerge working2) in
+ let working1_still_exists = Fs.file_exists (Fspath.concat workingDirForMerge working1) in
+ let working2_still_exists = Fs.file_exists (Fspath.concat workingDirForMerge working2) in
if working1_still_exists && working2_still_exists then begin
say (fun () -> Util.msg "No output from merge cmd and both original files are still present\n");
@@ -893,7 +895,7 @@
copyBack workingDirForMerge working1 root1 path desc1 ui1 id >>= (fun () ->
copyBack workingDirForMerge working2 root2 path desc2 ui2 id >>= (fun () ->
let arch_fspath = Fspath.concat workingDirForMerge workingarch in
- if (Sys.file_exists (Fspath.toString arch_fspath)) then begin
+ if Fs.file_exists arch_fspath then begin
debug (fun () -> Util.msg "Updating unison archives for %s to reflect results of merge\n"
(Path.toString path));
if not (Stasher.shouldBackupCurrent path) then
@@ -904,7 +906,7 @@
debug (fun () -> Util.msg "New digest is %s\n" (Os.fullfingerprint_to_string dig));
let new_archive_entry =
Update.ArchiveFile
- (Props.get (Fspath.stat arch_fspath) infoarch.osX, dig,
+ (Props.get (Fs.stat arch_fspath) infoarch.osX, dig,
Fileinfo.stamp (Fileinfo.get true arch_fspath Path.empty),
Osx.stamp infoarch.osX) in
Update.transaction
Modified: trunk/src/files.mli
===================================================================
--- trunk/src/files.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/files.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -63,12 +63,9 @@
(* terminated) synchronizations *)
val processCommitLogs : unit -> unit
-(* List the files in a directory matching a pattern. (It would be better
- to use fspath, etc., here instead of string) *)
-val ls : string -> string -> string list
+(* List the files in a directory matching a pattern. *)
+val ls : System.fspath -> string -> string list
-val get_files_in_directory : string -> string list
-
val merge :
Common.root (* first root *)
-> Common.root (* second root *)
Modified: trunk/src/fingerprint.ml
===================================================================
--- trunk/src/fingerprint.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/fingerprint.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -23,20 +23,21 @@
(* Assumes that (fspath, path) is a file and gives its ``digest '', that is *)
(* a short string of cryptographic quality representing it. *)
let file fspath path =
- let f = Fspath.toString (Fspath.concat fspath path) in
+ let f = Fspath.concat fspath path in
Util.convertUnixErrorsToTransient
- ("digesting " ^ f)
- (fun () -> Digest.file f)
+ ("digesting " ^ Fspath.toPrintString f)
+ (fun () -> Fs.digestFile f)
let maxLength = Uutil.Filesize.ofInt max_int
let subfile path offset len =
if len > maxLength then
raise (Util.Transient
- (Format.sprintf "File '%s' too big for fingerprinting" path));
+ (Format.sprintf "File '%s' too big for fingerprinting"
+ (Fspath.toPrintString path)));
Util.convertUnixErrorsToTransient
"digesting subfile"
(fun () ->
- let inch = open_in_bin path in
+ let inch = Fs.open_in_bin path in
begin try
LargeFile.seek_in inch offset;
let res = Digest.channel inch (Uutil.Filesize.toInt len) in
@@ -47,7 +48,8 @@
close_in_noerr inch;
raise (Util.Transient
(Format.sprintf
- "Error in digesting subfile '%s': truncated file" path))
+ "Error in digesting subfile '%s': truncated file"
+ (Fspath.toPrintString path)))
| e ->
close_in_noerr inch;
raise e
Modified: trunk/src/fingerprint.mli
===================================================================
--- trunk/src/fingerprint.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/fingerprint.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -5,7 +5,7 @@
(* Os.safeFingerprint should usually be used rather than these functions *)
val file : Fspath.t -> Path.local -> t
-val subfile : string -> Int64.t -> Uutil.Filesize.t -> t
+val subfile : Fspath.t -> Int64.t -> Uutil.Filesize.t -> t
val string : string -> t
Added: trunk/src/fs.ml
===================================================================
--- trunk/src/fs.ml (rev 0)
+++ trunk/src/fs.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,83 @@
+(* Unison file synchronizer: src/fs.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 = Fspath.t
+type dir_handle = System.dir_handle
+
+let symlink l f = System.symlink l (Fspath.toSysPath f)
+
+let readlink f = System.readlink (Fspath.toSysPath f)
+
+let chown f usr grp = System.chown (Fspath.toSysPath f) usr grp
+
+let chmod f mode = System.chmod (Fspath.toSysPath f) mode
+
+let utimes f t1 t2 = System.utimes (Fspath.toSysPath f) t1 t2
+
+let unlink f = System.unlink (Fspath.toSysPath f)
+
+let rmdir f = System.rmdir (Fspath.toSysPath f)
+
+let mkdir f mode = System.mkdir (Fspath.toSysPath f) mode
+
+let rename f f' = System.rename (Fspath.toSysPath f) (Fspath.toSysPath f')
+
+let stat f = System.stat (Fspath.toSysPath f)
+
+let lstat f = System.lstat (Fspath.toSysPath f)
+
+let openfile f flags perms = System.openfile (Fspath.toSysPath f) flags perms
+
+let opendir f = System.opendir (Fspath.toSysPath 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)
+
+let open_out_gen flags mode f =
+ System.open_out_gen flags mode (Fspath.toSysPath f)
+
+(****)
+
+let open_in_bin f = open_in_gen [Open_rdonly; Open_binary] 0 f
+
+let file_exists f =
+ try
+ ignore (stat f); true
+ with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
+ false
+
+(****)
+
+let digestFile f =
+ let ic = open_in_bin f in
+ let d = Digest.channel ic (-1) in
+ close_in ic;
+ d
+
+let canSetTime f =
+ Util.osType <> `Win32 ||
+ try
+ Unix.access (System.fspathToString (Fspath.toSysPath f)) [Unix.W_OK];
+ true
+ with
+ Unix.Unix_error _ -> false
+
+let useUnicodeEncoding _ = ()
Added: trunk/src/fs.mli
===================================================================
--- trunk/src/fs.mli (rev 0)
+++ trunk/src/fs.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,11 @@
+(* Unison file synchronizer: src/fs.mli *)
+(* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *)
+
+(* Operations on fspaths *)
+
+include System_intf.Core with type fspath = Fspath.t
+
+val digestFile : Fspath.t -> string
+val canSetTime : Fspath.t -> bool
+
+val useUnicodeEncoding : bool -> unit
Modified: trunk/src/fspath.ml
===================================================================
--- trunk/src/fspath.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/fspath.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -28,12 +28,21 @@
(* All fspaths are absolute *)
(* - *)
+module Fs = struct
+ let getcwd = System.getcwd
+ let chdir = System.chdir
+ let readlink = System.readlink
+end
+
let debug = Util.debug "fspath"
-let debugverbose = Util.debug "fspath+"
+let debugverbose = Util.debug "fsspath+"
type t = Fspath of string
let toString (Fspath f) = f
+let toPrintString (Fspath f) = f
+let toDebugString (Fspath f) = String.escaped f
+let toSysPath (Fspath f) = System.fspathFromString f
(* Needed to hack around some ocaml/Windows bugs, see comment at stat, below *)
let winRootRx = Rx.rx "(([a-zA-Z]:)?/|//[^/]+/[^/]+/)"
@@ -84,13 +93,19 @@
let appleDouble (Fspath f) =
if isRootDir f then raise(Invalid_argument "Fspath.appleDouble") else
let len = String.length f in
- let i = String.rindex f '/' in
- let before = String.sub f 0 i in
- let after = String.sub f (i+1) (len-i-1) in
- Fspath(before^"/._"^after)
+ try
+ let i = 1 + String.rindex f '/' in
+ let res = String.create (len + 2) in
+ String.blit f 0 res 0 i;
+ res.[i] <- '.';
+ res.[i + 1] <- '_';
+ String.blit f i res (i + 2) (len - i);
+ Fspath res
+ with Not_found ->
+ assert false
let rsrc (Fspath f) =
- if isRootDir f then raise(Invalid_argument "Fspath.appleDouble") else
+ if isRootDir f then raise(Invalid_argument "Fspath.rsrc") else
Fspath(f^"/..namedfork/rsrc")
(* WRAPPED SYSTEM CALLS *)
@@ -131,10 +146,9 @@
Unix.LargeFile.stat "c://" will fail.
(The Unix version of ocaml handles either a trailing slash or no
trailing slash.)
+
+Invariant on fspath will guarantee that argument is OK for stat
*)
-(* Invariant on fspath will guarantee that argument is OK for stat *)
-let stat (Fspath f) = Unix.LargeFile.stat f
-let lstat (Fspath f) = Unix.LargeFile.lstat f
(* HACK:
Under Windows 98,
@@ -148,13 +162,14 @@
Unix.opendir "c:" works as well, but, this refers to the current
working directory AFAIK.
-*)
+
let opendir (Fspath d) =
if Util.osType<>`Win32 || not(isRootDir d) then Unix.opendir d else
try
Unix.opendir d
with Unix.Unix_error _ ->
Unix.opendir (d^"*")
+*)
let child (Fspath f) n =
(* Note, f is not "" by invariants on Fspath *)
@@ -225,16 +240,18 @@
(* 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 = match p0 with None -> "." | Some "" -> "." | Some s -> s in
+ let p =
+ System.fspathFromString
+ (match p0 with None -> "." | Some "" -> "." | Some s -> s) in
let p' =
begin
- let original = Sys.getcwd() in
+ let original = Fs.getcwd() in
try
let newp =
- (Sys.chdir p; (* This might raise Sys_error *)
- Sys.getcwd()) in
- Sys.chdir original;
- newp
+ (Fs.chdir p; (* This might raise Sys_error *)
+ Fs.getcwd()) in
+ Fs.chdir original;
+ System.fspathToString newp
with
Sys_error why ->
(* We could not chdir to p. Either *)
@@ -247,18 +264,19 @@
(* 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 Sys.chdir parent with
+ (try Fs.chdir (System.fspathFromString 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)));
- Sys.getcwd() end in
- Sys.chdir original;
+ System.fspathToString (Fs.getcwd()) end in
+ Fs.chdir original;
let bn = Filename.basename p in
if bn="" then parent'
else toString(child (localString2fspath parent')
@@ -287,31 +305,32 @@
let canonize x =
Util.convertUnixErrorsToFatal "canonizing path" (fun () -> canonizeFspath x)
-let concatToString fspath path = toString (concat fspath path)
-
let maxlinks = 100
let findWorkingDir fspath path =
- let abspath = concatToString fspath path in
+ let abspath = toSysPath (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" abspath));
+ "Too many symbolic links from %s"
+ (System.fspathToPrintString abspath)));
try
- let link = Unix.readlink p in
+ let link = Fs.readlink p in
let linkabs =
if Filename.is_relative link then
- Filename.concat (Filename.dirname p) link
- else link in
+ System.fspathConcat (System.fspathDirname p) link
+ else System.fspathFromString 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" abspath));
+ "The path %s is a root directory"
+ (System.fspathToPrintString abspath)));
let realpath = Fileutil.removeTrailingSlashes realpath in
let p = Filename.basename realpath in
debug
@@ -322,3 +341,7 @@
(myDirname realpath)
p);
(localString2fspath (myDirname realpath), Path.fromString p)
+
+let quotes (Fspath f) = Uutil.quotes f
+let compare (Fspath f1) (Fspath f2) = compare f1 f2
+let hash (Fspath f) = Hashtbl.hash f
Modified: trunk/src/fspath.mli
===================================================================
--- trunk/src/fspath.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/fspath.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -10,7 +10,9 @@
val canonize : string option -> t
val toString : t -> string
-val concatToString : t -> Path.local -> string
+val toPrintString : t -> string
+val toDebugString : t -> string
+val toSysPath : t -> System.fspath
(* If fspath+path refers to a (followed) symlink, then return the directory *)
(* of the symlink's target; otherwise return the parent dir of path. If *)
@@ -26,8 +28,10 @@
(* Return the resource fork filename; if root dir, raise Invalid_argument *)
val rsrc : t -> t
-(* Wrapped system calls that use invariants of the fspath internal rep *)
-(* BE SURE TO USE ONLY THESE, NOT VERSIONS FROM THE UNIX MODULE! *)
-val stat : t -> Unix.LargeFile.stats
-val lstat : t -> Unix.LargeFile.stats
-val opendir : t -> Unix.dir_handle
+(* Escaped fspath (to pass as shell parameter) *)
+val quotes : t -> string
+
+(* CASE-SENSITIVE comparison between fspaths *)
+val compare : t -> t -> int
+(* CASE-SENSITIVE hash of a fspath *)
+val hash : t -> int
Deleted: trunk/src/linktk.ml
===================================================================
--- trunk/src/linktk.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/linktk.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -1,19 +0,0 @@
-(* Unison file synchronizer: src/linktk.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 TopLevel = Main.Body(Uitk.Body)
Modified: trunk/src/lock.ml
===================================================================
--- trunk/src/lock.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/lock.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -17,23 +17,23 @@
let rename oldFile newFile =
- begin try Unix.link oldFile newFile with Unix.Unix_error _ -> () end;
- let res = try (Unix.LargeFile.stat oldFile).Unix.LargeFile.st_nlink = 2
+ begin try System.link oldFile newFile with Unix.Unix_error _ -> () end;
+ let res = try (System.stat oldFile).Unix.LargeFile.st_nlink = 2
with Unix.Unix_error _ -> false
in
- Unix.unlink oldFile;
+ System.unlink oldFile;
res
let flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL]
let create name mode =
try
- Unix.close (Unix.openfile name flags mode);
+ Unix.close (System.openfile name flags mode);
true
with Unix.Unix_error (Unix.EEXIST, _, _) ->
false
let rec unique name i mode =
- let nm = name ^ string_of_int i in
+ let nm = System.fspathAddSuffixToFinalName name (string_of_int i) in
if create nm mode then nm else
(* highly unlikely *)
unique name (i + 1) mode
@@ -48,9 +48,9 @@
| _ ->
create name 0o600)
-let release name = try Unix.unlink name with Unix.Unix_error _ -> ()
+let release name = try System.unlink name with Unix.Unix_error _ -> ()
let is_locked name =
Util.convertUnixErrorsToTransient
"Lock.test"
- (fun () -> Sys.file_exists name)
+ (fun () -> System.file_exists name)
Modified: trunk/src/lock.mli
===================================================================
--- trunk/src/lock.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/lock.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -4,6 +4,6 @@
(* A simple utility module for setting and releasing inter-process locks
using entries in the filesystem. *)
-val acquire : string -> bool
-val release : string -> unit
-val is_locked : string -> bool
+val acquire : System.fspath -> bool
+val release : System.fspath -> unit
+val is_locked : System.fspath -> bool
Modified: trunk/src/lwt/lwt_unix.ml
===================================================================
--- trunk/src/lwt/lwt_unix.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/lwt/lwt_unix.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -14,6 +14,9 @@
- [connect] is blocking
*)
let windows_hack = Sys.os_type <> "Unix"
+let recent_ocaml =
+ Scanf.sscanf Sys.ocaml_version "%d.%d"
+ (fun maj min -> (maj = 3 && min >= 11) || maj > 3)
module SleepQueue =
Pqueue.Make (struct
@@ -112,7 +115,7 @@
let infds = List.map fst !inputs in
let outfds = List.map fst !outputs in
let (readers, writers, _) =
- if windows_hack then
+ if windows_hack && not recent_ocaml then
let writers = outfds in
let readers =
if delay = 0. || writers <> [] then [] else infds in
Modified: trunk/src/main.ml
===================================================================
--- trunk/src/main.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/main.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -186,7 +186,7 @@
this in Util just because the Prefs module lives below the Os module in the
dependency hierarchy, so Prefs can't call Os directly.) *)
Util.supplyFileInUnisonDirFn
- (fun n -> Fspath.toString (Os.fileInUnisonDir(n)));
+ (fun n -> Os.fileInUnisonDir(n));
(* Start a server if requested *)
if Util.StringMap.mem serverPrefName argv then begin
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/mkProjectInfo.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -147,3 +147,4 @@
+
Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/os.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -22,7 +22,7 @@
let debug = Util.debug "os"
let myCanonicalHostName =
- try Unix.getenv "UNISONLOCALHOSTNAME"
+ try System.getenv "UNISONLOCALHOSTNAME"
with Not_found -> Unix.gethostname()
let tempFilePrefix = ".unison."
@@ -43,22 +43,7 @@
xferDelete := del;
xferRename := ren
-
(*****************************************************************************)
-(* ESCAPING SHELL PARAMETERS *)
-(*****************************************************************************)
-
-(* Using single quotes is simpler under Unix but they are not accepted
- by the Windows shell. Double quotes without further quoting is
- sufficient with Windows as filenames are not allowed to contain
- double quotes. *)
-let quotes s =
- if Util.osType = `Win32 && not Util.isCygwin then
- "\"" ^ s ^ "\""
- else
- "'" ^ Util.replacesubstring s "'" "'\\''" ^ "'"
-
-(*****************************************************************************)
(* QUERYING THE FILESYSTEM *)
(*****************************************************************************)
@@ -69,8 +54,8 @@
Util.convertUnixErrorsToTransient
"reading symbolic link"
(fun () ->
- let abspath = Fspath.concatToString fspath path in
- Unix.readlink abspath)
+ let abspath = Fspath.concat fspath path in
+ Fs.readlink abspath)
let rec isAppleDoubleFile file =
Prefs.read Osx.rsrc &&
@@ -83,7 +68,7 @@
"scanning directory"
(fun () ->
let rec loop children directory =
- let newFile = try Unix.readdir directory with End_of_file -> "" in
+ let newFile = try Fs.readdir directory with End_of_file -> "" in
if newFile = "" then children else
let newChildren =
if newFile = "." || newFile = ".." then
@@ -95,7 +80,7 @@
let absolutePath = Fspath.concat fspath path in
let directory =
try
- Some (Fspath.opendir absolutePath)
+ Some (Fs.opendir absolutePath)
with Unix.Unix_error (Unix.ENOENT, _, _) ->
(* FIX (in Ocaml): under Windows, when a directory is empty
(not even "." and ".."), FindFirstFile fails with
@@ -107,11 +92,11 @@
Some directory ->
begin try
let result = loop [] directory in
- Unix.closedir directory;
+ Fs.closedir directory;
result
with Unix.Unix_error _ as e ->
begin try
- Unix.closedir directory
+ Fs.closedir directory
with Unix.Unix_error _ -> () end;
raise e
end
@@ -143,12 +128,12 @@
if Props.time i.Fileinfo.desc +. secondsinthirtydays < Util.time()
then begin
debug (fun()-> Util.msg "deleting old temp file %s\n"
- (Fspath.concatToString fspath p));
+ (Fspath.toDebugString (Fspath.concat fspath p)));
delete fspath p
end else
debug (fun()-> Util.msg
"keeping temp file %s since it is less than 30 days old\n"
- (Fspath.concatToString fspath p));
+ (Fspath.toDebugString (Fspath.concat fspath p)));
end;
false
end else
@@ -164,55 +149,55 @@
Util.convertUnixErrorsToTransient
"deleting"
(fun () ->
- let absolutePath = Fspath.concatToString fspath path in
+ let absolutePath = Fspath.concat fspath path in
match (Fileinfo.get false fspath path).Fileinfo.typ with
`DIRECTORY ->
begin try
- Unix.chmod absolutePath 0o700
+ Fs.chmod absolutePath 0o700
with Unix.Unix_error _ -> () end;
Safelist.iter
(fun child -> delete fspath (Path.child path child))
(allChildrenOf fspath path);
(!xferDelete) (fspath, path);
- Unix.rmdir absolutePath
+ Fs.rmdir absolutePath
| `FILE ->
if Util.osType <> `Unix then begin
try
- Unix.chmod absolutePath 0o600;
+ Fs.chmod absolutePath 0o600;
with Unix.Unix_error _ -> ()
end;
(!xferDelete) (fspath, path);
- Unix.unlink absolutePath;
+ Fs.unlink absolutePath;
if Prefs.read Osx.rsrc then begin
- let pathDouble = Osx.appleDoubleFile fspath path in
- if Sys.file_exists pathDouble then
- Unix.unlink pathDouble
+ let pathDouble = Fspath.appleDouble absolutePath in
+ if Fs.file_exists pathDouble then
+ Fs.unlink pathDouble
end
| `SYMLINK ->
(* Note that chmod would not do the right thing on links *)
- Unix.unlink absolutePath
+ Fs.unlink absolutePath
| `ABSENT ->
())
let rename fname sourcefspath sourcepath targetfspath targetpath =
let source = Fspath.concat sourcefspath sourcepath in
- let source' = Fspath.toString source in
+ let source' = Fspath.toPrintString source in
let target = Fspath.concat targetfspath targetpath in
- let target' = Fspath.toString target in
- if source' = target' then
+ let target' = Fspath.toPrintString target in
+ if source = target then
raise (Util.Transient ("Rename ("^fname^"): identical source and target " ^ source'));
Util.convertUnixErrorsToTransient ("renaming " ^ source' ^ " to " ^ target')
(fun () ->
debug (fun() -> Util.msg "rename %s to %s\n" source' target');
(!xferRename) (sourcefspath, sourcepath) (targetfspath, targetpath);
- Unix.rename source' target';
+ Fs.rename source target;
if Prefs.read Osx.rsrc then begin
- let sourceDouble = Osx.appleDoubleFile sourcefspath sourcepath in
- let targetDouble = Osx.appleDoubleFile targetfspath targetpath in
- if Sys.file_exists sourceDouble then
- Unix.rename sourceDouble targetDouble
- else if Sys.file_exists targetDouble then
- Unix.unlink targetDouble
+ let sourceDouble = Fspath.appleDouble source in
+ let targetDouble = Fspath.appleDouble target in
+ if Fs.file_exists sourceDouble then
+ Fs.rename sourceDouble targetDouble
+ else if Fs.file_exists targetDouble then
+ Fs.unlink targetDouble
end)
let symlink =
@@ -221,8 +206,8 @@
Util.convertUnixErrorsToTransient
"writing symbolic link"
(fun () ->
- let abspath = Fspath.concatToString fspath path in
- Unix.symlink l abspath)
+ let abspath = Fspath.concat fspath path in
+ Fs.symlink l abspath)
else
fun fspath path l ->
raise (Util.Transient "symlink not supported under Win32")
@@ -232,8 +217,8 @@
Util.convertUnixErrorsToTransient
"creating directory"
(fun () ->
- let absolutePath = Fspath.concatToString fspath path in
- Unix.mkdir absolutePath (Props.perms props))
+ let absolutePath = Fspath.concat fspath path in
+ Fs.mkdir absolutePath (Props.perms props))
(*****************************************************************************)
(* FINGERPRINTS *)
@@ -254,7 +239,7 @@
(Printf.sprintf
"Failed to fingerprint file \"%s\": \
the file keeps on changing"
- (Fspath.concatToString fspath path)))
+ (Fspath.toPrintString (Fspath.concat fspath path))))
else
let dig =
match optDig with
@@ -296,35 +281,35 @@
(* Gives the fspath of the archive directory on the machine, depending on *)
(* which OS we use *)
let unisonDir =
- try Fspath.canonize (Some (Unix.getenv "UNISON"))
+ try
+ System.fspathFromString (System.getenv "UNISON")
with Not_found ->
- let genericName = Util.fileInHomeDir (Printf.sprintf ".%s" Uutil.myName) in
- if Osx.isMacOSX then
- let osxName = Util.fileInHomeDir "Library/Application Support/Unison" in
- if Sys.file_exists genericName then Fspath.canonize (Some genericName)
- else Fspath.canonize (Some osxName)
+ let genericName =
+ Util.fileInHomeDir (Printf.sprintf ".%s" Uutil.myName) in
+ if Osx.isMacOSX && not (System.file_exists genericName) then
+ Util.fileInHomeDir "Library/Application Support/Unison"
else
- Fspath.canonize (Some genericName)
+ genericName
(* build a fspath representing an archive child path whose name is given *)
let fileInUnisonDir str =
- let n =
- try Name.fromString str
- with Invalid_argument _ ->
- raise (Util.Transient
- ("Ill-formed name of file in UNISON directory: "^str))
- in
- Fspath.child unisonDir n
+ begin try
+ ignore (Name.fromString str)
+ with Invalid_argument _ ->
+ raise (Util.Transient
+ ("Ill-formed name of file in UNISON directory: "^str))
+ end;
+ System.fspathConcat unisonDir str
(* Make sure archive directory exists *)
let createUnisonDir() =
- try ignore (Fspath.stat unisonDir)
+ try ignore (System.stat unisonDir)
with Unix.Unix_error(_) ->
Util.convertUnixErrorsToFatal
(Printf.sprintf "creating unison directory %s"
- (Fspath.toString unisonDir))
+ (System.fspathToPrintString unisonDir))
(fun () ->
- ignore (Unix.mkdir (Fspath.toString unisonDir) 0o700))
+ ignore (System.mkdir unisonDir 0o700))
(*****************************************************************************)
(* TEMPORARY FILES *)
Modified: trunk/src/os.mli
===================================================================
--- trunk/src/os.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/os.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -10,8 +10,8 @@
val exists : Fspath.t -> Path.local -> bool
val createUnisonDir : unit -> unit
-val fileInUnisonDir : string -> Fspath.t
-val unisonDir : Fspath.t
+val fileInUnisonDir : string -> System.fspath
+val unisonDir : System.fspath
val childrenOf : Fspath.t -> Path.local -> Name.t list
val readLink : Fspath.t -> Path.local -> string
@@ -54,5 +54,3 @@
(Fspath.t * Path.local -> unit) ->
((Fspath.t * Path.local) -> (Fspath.t * Path.local) -> unit) ->
unit
-
-val quotes : string -> string
Modified: trunk/src/osx.ml
===================================================================
--- trunk/src/osx.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/osx.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -48,20 +48,6 @@
(****)
-let appleDoubleFile fspath path =
- let f = Fspath.concatToString fspath path in
- let len = String.length f in
- try
- let i = 1 + String.rindex f '/' in
- let res = String.create (len + 2) in
- String.blit f 0 res 0 i;
- res.[i] <- '.';
- res.[i + 1] <- '_';
- String.blit f i res (i + 2) (len - i);
- res
- with Not_found ->
- assert false
-
let doubleMagic = "\000\005\022\007"
let doubleVersion = "\000\002\000\000"
let doubleFiller = String.make 16 '\000'
@@ -96,7 +82,8 @@
let fail path msg =
raise (Util.Transient
- (Format.sprintf "Malformed AppleDouble file '%s' (%s)" path msg))
+ (Format.sprintf "Malformed AppleDouble file '%s' (%s)"
+ (Fspath.toPrintString path) msg))
let readDouble path inch len =
let buf = String.create len in
@@ -123,8 +110,8 @@
raise e
let openDouble fspath path =
- let path = appleDoubleFile fspath path in
- let inch = try open_in_bin path with Sys_error _ -> raise Not_found 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
protect (fun () ->
Util.convertUnixErrorsToTransient "opening AppleDouble file" (fun () ->
let header = readDouble path inch 26 in
@@ -166,12 +153,13 @@
ino mtime ctime (Uutil.Filesize.toString len)
type info =
- { ressInfo : (string * int64) ressInfo;
+ { ressInfo : (Fspath.t * int64) ressInfo;
finfo : string }
external getFileInfosInternal :
- string -> bool -> string * int64 = "getFileInfos"
-external setFileInfosInternal : string -> string -> unit = "setFileInfos"
+ System.fspath -> bool -> string * int64 = "getFileInfos"
+external setFileInfosInternal :
+ System.fspath -> string -> unit = "setFileInfos"
let defaultInfos typ =
match typ with
@@ -216,7 +204,7 @@
try
let (fInfo, rsrcLength) =
getFileInfosInternal
- (Fspath.concatToString fspath path) (typ = `FILE) in
+ (Fspath.toSysPath (Fspath.concat fspath path)) (typ = `FILE) in
{ ressInfo =
if rsrcLength = 0L then NoRess
else HfsRess (Uutil.Filesize.ofInt64 rsrcLength);
@@ -242,7 +230,7 @@
"")
(fun () -> close_in_noerr inch)
in
- let stats = Unix.LargeFile.stat doublePath in
+ let stats = Fs.stat doublePath in
{ ressInfo =
if rsrcLength = 0L then NoRess else
AppleDoubleRess
@@ -286,10 +274,9 @@
assert (finfo <> "");
Util.convertUnixErrorsToTransient "setting file informations" (fun () ->
try
- let (fullFinfo, _) =
- getFileInfosInternal (Fspath.concatToString fspath path) false in
- setFileInfosInternal (Fspath.concatToString fspath path)
- (insertInfo fullFinfo finfo)
+ let p = Fspath.toSysPath (Fspath.concat fspath path) 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 (fspath, path) = Fspath.findWorkingDir fspath path in
@@ -307,7 +294,7 @@
(fun () -> close_in_noerr inch)
in
let outch =
- open_out_gen [Open_wronly; Open_binary] 0o600 doublePath in
+ Fs.open_out_gen [Open_wronly; Open_binary] 0o600 doublePath in
protect
(fun () ->
writeDoubleFromOffset doublePath outch ofs
@@ -321,14 +308,14 @@
(Format.sprintf
"Unable to set the file type and creator: \n\
The AppleDouble file '%s' has no fileinfo entry."
- doublePath))
+ (Fspath.toPrintString doublePath)))
end
with Not_found ->
(* No AppleDouble file, create one if needed. *)
if finfo <> "F" && finfo <> "D" then begin
- let path = appleDoubleFile fspath path in
+ let path = Fspath.appleDouble (Fspath.concat fspath path) in
let outch =
- open_out_gen
+ Fs.open_out_gen
[Open_wronly; Open_creat; Open_excl; Open_binary] 0o600 path
in
protect (fun () ->
@@ -403,8 +390,8 @@
Util.convertUnixErrorsToTransient "reading resource fork" (fun () ->
try
Unix.in_channel_of_descr
- (Unix.openfile
- (Fspath.concatToString fspath (ressPath path))
+ (Fs.openfile
+ (Fspath.concat fspath (ressPath path))
[Unix.O_RDONLY] 0o444)
with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
let (doublePath, inch, entries) = openDouble fspath path in
@@ -421,13 +408,13 @@
Util.convertUnixErrorsToTransient "writing resource fork" (fun () ->
try
Unix.out_channel_of_descr
- (Unix.openfile
- (Fspath.concatToString fspath (ressPath path))
+ (Fs.openfile
+ (Fspath.concat fspath (ressPath path))
[Unix.O_WRONLY;Unix.O_TRUNC] 0o600)
with Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
- let path = appleDoubleFile fspath path in
+ let path = Fspath.appleDouble (Fspath.concat fspath path) in
let outch =
- open_out_gen
+ Fs.open_out_gen
[Open_wronly; Open_creat; Open_excl; Open_binary] 0o600 path
in
protect (fun () ->
Modified: trunk/src/osx.mli
===================================================================
--- trunk/src/osx.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/osx.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -9,9 +9,11 @@
type 'a ressInfo
type ressStamp = unit ressInfo
type info =
- { ressInfo : (string * int64) ressInfo;
+ { ressInfo : (Fspath.t * int64) ressInfo;
finfo : string }
+val defaultInfos : [> `DIRECTORY | `FILE ] -> info
+
val getFileInfos : Fspath.t -> Path.local -> [> `DIRECTORY | `FILE ] -> info
val setFileInfos : Fspath.t -> Path.local -> string -> unit
@@ -26,7 +28,5 @@
val stamp : info -> ressStamp
-val appleDoubleFile : Fspath.t -> Path.local -> string
-
val openRessIn : Fspath.t -> Path.local -> in_channel
val openRessOut : Fspath.t -> Path.local -> Uutil.Filesize.t -> out_channel
Modified: trunk/src/props.ml
===================================================================
--- trunk/src/props.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/props.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -199,13 +199,13 @@
Util.convertUnixErrorsToTransient
"setting permissions"
(fun () ->
- let abspath = Fspath.concatToString fspath path in
+ let abspath = Fspath.concat fspath path in
debug
(fun() ->
Util.msg "Setting permissions for %s to %s (%s)\n"
- abspath (toString (fileperm2perm fp))
+ (Fspath.toDebugString abspath) (toString (fileperm2perm fp))
(Printf.sprintf "%o/%o" fp mask));
- Unix.chmod abspath fp)
+ Fs.chmod abspath fp)
let get stats _ = (stats.Unix.LargeFile.st_perm, Prefs.read permMask)
@@ -220,7 +220,7 @@
The filesystem probably does not support all permission bits. \
You should probably set the \"perms\" option to 0o%o \
(or to 0 if you don't need to synchronize permissions)."
- (Fspath.concatToString fspath path)
+ (Fspath.toPrintString (Fspath.concat fspath path))
(syncedPartsToString (fp, mask))
(syncedPartsToString (fp', mask))
(mask land (lnot (fp lxor fp')))))
@@ -261,7 +261,7 @@
val to_num : string -> int
val toString : int -> string
val syncedPartsToString : int -> string
- val set : string -> int -> unit
+ val set : Fspath.t -> int -> unit
val get : Unix.LargeFile.stats -> int
end) : S = struct
@@ -328,7 +328,7 @@
Util.convertUnixErrorsToTransient
"setting file ownership"
(fun () ->
- let abspath = Fspath.concatToString fspath path in
+ let abspath = Fspath.concat fspath path in
M.set abspath id)
let tbl = Hashtbl.create 17
@@ -366,7 +366,7 @@
let toString id = (Unix.getpwuid id).Unix.pw_name
let syncedPartsToString = toString
-let set path id = Unix.chown path id (-1)
+let set path id = Fs.chown path id (-1)
let get stats = stats.Unix.LargeFile.st_uid
end)
@@ -387,7 +387,7 @@
let toString id = (Unix.getgrgid id).Unix.gr_name
let syncedPartsToString = toString
-let set path id = Unix.chown path (-1) id
+let set path id = Fs.chown path (-1) id
let get stats = stats.Unix.LargeFile.st_gid
end)
@@ -488,13 +488,6 @@
Synced _ -> toString t
| NotSynced _ -> ""
-let iCanWrite p =
- try
- Unix.access p [Unix.W_OK];
- true
- with
- Unix.Unix_error _ -> false
-
(* FIX: Probably there should be a check here that prevents us from ever *)
(* setting a file's modtime into the future. *)
let set fspath path kind t =
@@ -503,8 +496,8 @@
Util.convertUnixErrorsToTransient
"setting modification time"
(fun () ->
- let abspath = Fspath.concatToString fspath path in
- if Util.osType = `Win32 && not (iCanWrite abspath) then
+ let abspath = Fspath.concat fspath path in
+ if not (Fs.canSetTime abspath) then
begin
(* Nb. This workaround was proposed by Dmitry Bely, to
work around the fact that Unix.utimes fails on readonly
@@ -518,12 +511,12 @@
certainly don't want to make it WORLD-writable, even
briefly!). *)
let oldPerms =
- (Unix.LargeFile.lstat abspath).Unix.LargeFile.st_perm in
+ (Fs.lstat abspath).Unix.LargeFile.st_perm in
Util.finalize
(fun()->
- Unix.chmod abspath 0o600;
- Unix.utimes abspath v v)
- (fun()-> Unix.chmod abspath oldPerms)
+ Fs.chmod abspath 0o600;
+ Fs.utimes abspath v v)
+ (fun()-> Fs.chmod abspath oldPerms)
end
else if false then begin
(* A special hack for Rasmus, who has a special situation that
@@ -540,12 +533,12 @@
time.Unix.tm_min
time.Unix.tm_sec in
let cmd = "/usr/local/bin/sudo -u root /usr/bin/touch -m -a -t "
- ^ tstr ^ " '" ^ abspath ^ "'" in
+ ^ tstr ^ " " ^ Fspath.quotes abspath in
Util.msg "Running external program to set utimes:\n %s\n" cmd;
let (r,_) = External.runExternalProgram cmd in
if r<>(Unix.WEXITED 0) then raise (Util.Transient "External time-setting command failed")
end else
- Unix.utimes abspath v v)
+ Fs.utimes abspath v v)
| _ ->
()
@@ -568,7 +561,7 @@
(Format.sprintf
"Failed to set modification time of file %s to %s: \
the time was set to %s instead"
- (Fspath.concatToString fspath path)
+ (Fspath.toPrintString (Fspath.concat fspath path))
(syncedPartsToString t)
(syncedPartsToString t')))
Modified: trunk/src/remote.ml
===================================================================
--- trunk/src/remote.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/remote.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -923,7 +923,7 @@
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. *)
- Unix.putenv "CYGWIN" "binmode";
+ System.putenv "CYGWIN" "binmode";
debug (fun ()-> Util.msg "Shell connection: %s (%s)\n"
shellCmd (String.concat ", " args));
let term =
@@ -1059,7 +1059,7 @@
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. *)
- Unix.putenv "CYGWIN" "binmode";
+ System.putenv "CYGWIN" "binmode";
debug (fun ()-> Util.msg "Shell connection: %s (%s)\n"
shellCmd (String.concat ", " args));
let (term,pid) =
@@ -1203,7 +1203,9 @@
let beAServer () =
begin try
- Sys.chdir (Sys.getenv "HOME")
+ Util.convertUnixErrorsToFatal
+ "changing working directory"
+ (fun () -> System.chdir (System.fspathFromString (System.getenv "HOME")))
with Not_found ->
Util.msg
"Environment variable HOME unbound: \
Modified: trunk/src/stasher.ml
===================================================================
--- trunk/src/stasher.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/stasher.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -133,13 +133,14 @@
let backupDirectory () =
Util.convertUnixErrorsToTransient "backupDirectory()" (fun () ->
- try Fspath.canonize (Some (Unix.getenv "UNISONBACKUPDIR"))
+ try Fspath.canonize (Some (System.getenv "UNISONBACKUPDIR"))
with Not_found ->
- try Fspath.canonize (Some (Unix.getenv "UNISONMIRRORDIR"))
+ try Fspath.canonize (Some (System.getenv "UNISONMIRRORDIR"))
with Not_found ->
if Prefs.read backupdir <> ""
then Fspath.canonize (Some (Prefs.read backupdir))
- else Os.fileInUnisonDir "backup")
+ else Fspath.canonize
+ (Some (System.fspathToString (Os.fileInUnisonDir "backup"))))
let backupcurrent =
Pred.create "backupcurr" ~advanced:true
@@ -315,7 +316,8 @@
let rec mkdirectories backdir =
verbose (fun () -> Util.msg
- "mkdirectories %s %s\n" (Fspath.toString sFspath) (Path.toString backdir));
+ "mkdirectories %s %s\n"
+ (Fspath.toDebugString sFspath) (Path.toString backdir));
if not (Os.exists sFspath Path.empty) then
Os.createDir sFspath Path.empty Props.dirDefault;
match Path.deconstructRev backdir with
@@ -336,16 +338,16 @@
then begin
debug (fun()-> Util.msg
"[%s / %s] = [%s / %s] = %s: no need to back up\n"
- (Fspath.toString sFspath) (Path.toString path0)
- (Fspath.toString fspath) (Path.toString path)
+ (Fspath.toDebugString sFspath) (Path.toString path0)
+ (Fspath.toDebugString fspath) (Path.toString path)
(showContent sourceTyp fspath path));
None
end else begin
debug (fun()-> Util.msg
"stashed [%s / %s] = %s is not equal to new [%s / %s] = %s (or one is a dir): stash!\n"
- (Fspath.toString sFspath) (Path.toString path0)
+ (Fspath.toDebugString sFspath) (Path.toString path0)
(showContent path0Typ sFspath path0)
- (Fspath.toString fspath) (Path.toString path)
+ (Fspath.toDebugString fspath) (Path.toString path)
(showContent sourceTyp fspath path));
let sPath = f 0 in
(* Make sure the parent directory exists *)
@@ -361,7 +363,7 @@
let backup fspath path (finalDisposition : [`AndRemove | `ByCopying]) =
debug (fun () -> Util.msg
"backup: %s / %s\n"
- (Fspath.toString fspath)
+ (Fspath.toDebugString fspath)
(Path.toString path));
Util.convertUnixErrorsToTransient "backup" (fun () ->
let disposeIfNeeded() =
@@ -370,41 +372,41 @@
if not (Os.exists fspath path) then
debug (fun () -> Util.msg
"File %s in %s does not exist, so no need to back up\n"
- (Path.toString path) (Fspath.toString fspath))
+ (Path.toString path) (Fspath.toDebugString fspath))
else if shouldBackup path then begin
match backupPath fspath path with
None -> disposeIfNeeded()
| Some (backRoot, backPath) ->
debug (fun () -> Util.msg "Backing up %s / %s to %s in %s\n"
- (Fspath.toString fspath) (Path.toString path)
- (Path.toString backPath) (Fspath.toString backRoot));
+ (Fspath.toDebugString fspath) (Path.toString path)
+ (Path.toString backPath) (Fspath.toDebugString backRoot));
let byCopying() =
let rec copy p backp =
let info = Fileinfo.get true fspath p in
match info.Fileinfo.typ with
| `SYMLINK ->
debug (fun () -> Util.msg " Copying link %s / %s to %s / %s\n"
- (Fspath.toString fspath) (Path.toString p)
- (Fspath.toString backRoot) (Path.toString backp));
+ (Fspath.toDebugString fspath) (Path.toString p)
+ (Fspath.toDebugString backRoot) (Path.toString backp));
Os.symlink backRoot backp (Os.readLink fspath p)
| `FILE ->
debug (fun () -> Util.msg " Copying file %s / %s to %s / %s\n"
- (Fspath.toString fspath) (Path.toString p)
- (Fspath.toString backRoot) (Path.toString backp));
+ (Fspath.toDebugString fspath) (Path.toString p)
+ (Fspath.toDebugString backRoot) (Path.toString backp));
Copy.localFile fspath p backRoot backp backp
`Copy info.Fileinfo.desc
(Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) None
| `DIRECTORY ->
debug (fun () -> Util.msg " Copying directory %s / %s to %s / %s\n"
- (Fspath.toString fspath) (Path.toString p)
- (Fspath.toString backRoot) (Path.toString backp));
+ (Fspath.toDebugString fspath) (Path.toString p)
+ (Fspath.toDebugString backRoot) (Path.toString backp));
Os.createDir backRoot backp info.Fileinfo.desc;
let ch = Os.childrenOf fspath p in
Safelist.iter (fun n -> copy (Path.child p n) (Path.child backp n)) ch
| `ABSENT -> assert false in
copy path backPath;
debug (fun () -> Util.msg " Finished copying; deleting %s / %s\n"
- (Fspath.toString fspath) (Path.toString path));
+ (Fspath.toDebugString fspath) (Path.toString path));
disposeIfNeeded() in
try
if finalDisposition = `AndRemove then
@@ -416,7 +418,7 @@
byCopying()
end else begin
debug (fun () -> Util.msg "Path %s / %s does not need to be backed up\n"
- (Fspath.toString fspath)
+ (Fspath.toDebugString fspath)
(Path.toString path));
disposeIfNeeded()
end)
@@ -428,7 +430,7 @@
Util.convertUnixErrorsToTransient "stashCurrentVersion" (fun () ->
let sourcePath = match sourcePathOpt with None -> path | Some p -> p in
debug (fun () -> Util.msg "stashCurrentVersion of %s (drawn from %s) in %s\n"
- (Path.toString path) (Path.toString sourcePath) (Fspath.toString fspath));
+ (Path.toString path) (Path.toString sourcePath) (Fspath.toDebugString fspath));
let stat = Fileinfo.get true fspath sourcePath in
match stat.Fileinfo.typ with
`ABSENT -> ()
@@ -469,7 +471,7 @@
debug (fun () ->
Util.msg "getRecentVersion of %s in %s\n"
(Path.toString path)
- (Fspath.toString fspath));
+ (Fspath.toDebugString fspath));
Util.convertUnixErrorsToTransient "getRecentVersion" (fun () ->
let dir = stashDirectory fspath in
let rec aux_find i =
@@ -481,13 +483,13 @@
debug (fun () ->
Util.msg "recent version %s found in %s\n"
(Path.toString path)
- (Fspath.toString dir));
+ (Fspath.toDebugString dir));
Some (Fspath.concat dir path)
end else
if i = Prefs.read maxbackups then begin
debug (fun () ->
Util.msg "No recent version was available for %s on this root.\n"
- (Fspath.toString (Fspath.concat fspath path)));
+ (Fspath.toDebugString (Fspath.concat fspath path)));
None
end else
aux_find (i+1)
Added: trunk/src/system.ml
===================================================================
--- trunk/src/system.ml (rev 0)
+++ trunk/src/system.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,19 @@
+(* 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.mli
===================================================================
--- trunk/src/system.mli (rev 0)
+++ trunk/src/system.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,6 @@
+(* Unison file synchronizer: src/system.mli *)
+(* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *)
+
+(* Operations on filesystem path *)
+
+include System_intf.Full
Added: trunk/src/system_generic.ml
===================================================================
--- trunk/src/system_generic.ml (rev 0)
+++ trunk/src/system_generic.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,63 @@
+(* 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
Property changes on: trunk/src/system_generic.ml
___________________________________________________________________
Name: svn:executable
+ *
Added: trunk/src/system_intf.ml
===================================================================
--- trunk/src/system_intf.ml (rev 0)
+++ trunk/src/system_intf.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,70 @@
+(* 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
Added: trunk/src/system_win.ml
===================================================================
--- trunk/src/system_win.ml (rev 0)
+++ trunk/src/system_win.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,194 @@
+(* 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
Property changes on: trunk/src/system_win.ml
___________________________________________________________________
Name: svn:executable
+ *
Added: trunk/src/system_win_stubs.c
===================================================================
--- trunk/src/system_win_stubs.c (rev 0)
+++ trunk/src/system_win_stubs.c 2009-05-13 18:02:17 UTC (rev 331)
@@ -0,0 +1,464 @@
+#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);
+}
Property changes on: trunk/src/system_win_stubs.c
___________________________________________________________________
Name: svn:executable
+ *
Modified: trunk/src/test.ml
===================================================================
--- trunk/src/test.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/test.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -25,25 +25,25 @@
let verbose = Trace.debug "test"
let rec remove_file_or_dir d =
- match try Some(Unix.lstat d) with Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) -> None with
+ match try Some(Fs.lstat d) with Unix.Unix_error((Unix.ENOENT | Unix.ENOTDIR),_,_) -> None with
| Some(s) ->
- if s.Unix.st_kind = Unix.S_DIR then begin
- let handle = Unix.opendir d in
+ if s.Unix.LargeFile.st_kind = Unix.S_DIR then begin
+ let handle = Fs.opendir d in
let rec loop () =
- let r = try Some(Unix.readdir handle) with End_of_file -> None in
+ let r = try Some(Fs.readdir handle) with End_of_file -> None in
match r with
| Some f ->
if f="." || f=".." then loop ()
else begin
- remove_file_or_dir (d^"/"^f);
+ remove_file_or_dir (Fspath.concat d (Path.fromString f));
loop ()
end
| None ->
- Unix.closedir handle;
- Unix.rmdir d
+ Fs.closedir handle;
+ Fs.rmdir d
in loop ()
end else
- Sys.remove d
+ Fs.unlink d
| None -> ()
let read_chan chan =
@@ -53,10 +53,12 @@
string
let read file =
+(*
if file = "-" then
read_chan stdin
- else
- let chan = open_in_bin file in
+ else
+*)
+ let chan = Fs.open_in_bin file in
try
let r = read_chan chan in
close_in chan;
@@ -66,10 +68,14 @@
raise exn
let write file s =
+(*
if file = "-" then
output_string stdout s
- else
- let chan = open_out_bin file in
+ else
+*)
+ let chan =
+ Fs.open_out_gen
+ [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 file in
try
output_string chan s;
close_out chan
@@ -79,20 +85,19 @@
let read_dir d =
let ignored = ["."; ".."] in
- let d = Unix.opendir d in
+ let d = Fs.opendir d in
let rec do_read acc =
try
- (match (Unix.readdir d) with
+ (match (Fs.readdir d) with
| s when Safelist.mem s ignored -> do_read acc
| f -> do_read (f :: acc))
with End_of_file -> acc
in
let files = do_read [] in
- Unix.closedir d;
+ Fs.closedir d;
files
-let extend p file =
- p ^ "/" ^ file
+let extend p file = Fspath.concat p (Path.fromString file)
type fs =
| File of string
@@ -124,10 +129,10 @@
let readfs p =
let rec loop p =
- let s = Unix.lstat p in
- match s.Unix.st_kind with
+ let s = Fs.lstat p in
+ match s.Unix.LargeFile.st_kind with
| Unix.S_REG -> File (read p)
- | Unix.S_LNK -> Link (Unix.readlink p)
+ | Unix.S_LNK -> Link (Fs.readlink p)
| Unix.S_DIR -> Dir (Safelist.map (fun x -> (x, loop (extend p x))) (read_dir p))
| _ -> assert false
in try Some(loop p) with
@@ -140,11 +145,11 @@
let rec loop p = function
| File s ->
verbose (fun() -> Util.msg "Writing %s with contents %s (fingerprint %s)\n"
- p s (Fingerprint.toString (Fingerprint.string s)));
+ (Fspath.toDebugString p) s (Fingerprint.toString (Fingerprint.string s)));
write p s
- | Link s -> Unix.symlink s p
+ | Link s -> Fs.symlink s p
| Dir files ->
- Unix.mkdir p default_perm;
+ Fs.mkdir p default_perm;
Safelist.iter (fun (x,cont) -> loop (extend p x) cont) files
in
remove_file_or_dir p;
@@ -157,41 +162,41 @@
if Os.exists fspath Path.empty then
raise (Util.Fatal (Printf.sprintf
"Path %s is not empty at start of tests!"
- (Fspath.toString fspath)));
+ (Fspath.toPrintString fspath)));
Lwt.return ())
let makeRootEmpty : Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
"makeRootEmpty"
(fun (fspath, ()) ->
- remove_file_or_dir (Fspath.toString fspath);
+ remove_file_or_dir fspath;
Lwt.return ())
let getfs : Common.root -> unit -> (fs option) Lwt.t =
Remote.registerRootCmd
"getfs"
(fun (fspath, ()) ->
- Lwt.return (readfs (Fspath.toString fspath)))
+ Lwt.return (readfs fspath))
let getbackup : Common.root -> unit -> (fs option) Lwt.t =
Remote.registerRootCmd
"getbackup"
(fun (fspath, ()) ->
- Lwt.return (readfs (Fspath.toString (Stasher.backupDirectory ()))))
+ Lwt.return (readfs (Stasher.backupDirectory ())))
let makeBackupEmpty : Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
"makeBackupEmpty"
(fun (fspath, ()) ->
- let b = Fspath.toString (Stasher.backupDirectory ()) in
- debug (fun () -> Util.msg "Removing %s\n" b);
+ let b = Stasher.backupDirectory () in
+ debug (fun () -> Util.msg "Removing %s\n" (Fspath.toDebugString b));
Lwt.return (remove_file_or_dir b))
let putfs : Common.root -> fs -> unit Lwt.t =
Remote.registerRootCmd
"putfs"
(fun (fspath, fs) ->
- writefs (Fspath.toString fspath) fs;
+ writefs fspath fs;
Lwt.return ())
let loadPrefs l =
@@ -257,7 +262,7 @@
(Globals.rawRoots())) then
raise (Util.Fatal
"Self-tests can only be run if both roots include the string 'test'");
- if Util.findsubstring "test" (Fspath.toString (Stasher.backupDirectory())) = None then
+ if Util.findsubstring "test" (Fspath.toPrintString (Stasher.backupDirectory())) = None then
raise (Util.Fatal
("Self-tests can only be run if the 'backupdir' preference (or wherever the backup "
^ "directory name is coming from, e.g. the UNISONBACKUPDIR environment variable) "
Modified: trunk/src/ubase/prefs.ml
===================================================================
--- trunk/src/ubase/prefs.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/ubase/prefs.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -19,7 +19,7 @@
let profilePathname n =
let f = Util.fileInUnisonDir n in
- if Sys.file_exists f then f
+ if System.file_exists f then f
else Util.fileInUnisonDir (n ^ ".prf")
let thePrefsFile () =
@@ -146,6 +146,11 @@
(fun v -> [v])
(fun cell -> Uarg.String (fun s -> set cell s))
+let createFspath name default doc fulldoc =
+ createPrefInternal name default doc fulldoc
+ (fun v -> [System.fspathToString v])
+ (fun cell -> Uarg.String (fun s -> set cell (System.fspathFromString s)))
+
let createStringList name doc fulldoc =
createPrefInternal name [] doc fulldoc
(fun v -> v)
@@ -260,7 +265,7 @@
in the same order as in the file. *)
let rec readAFile filename : (string * int * string * string) list =
let chan =
- try open_in (profilePathname filename)
+ try System.open_in_bin (profilePathname filename)
with Sys_error _ ->
raise(Util.Fatal(Printf.sprintf "Preference file %s not found" filename)) in
let rec loop lines =
@@ -370,10 +375,12 @@
then profilePathname (read addprefsto)
else thePrefsFile() in
try
- debug (fun() -> Util.msg "Adding '%s' to %s\n" l filename);
- let resultmsg = l ^ "' added to profile " ^ filename in
+ debug (fun() ->
+ Util.msg "Adding '%s' to %s\n" l (System.fspathToDebugString filename));
+ let resultmsg =
+ l ^ "' added to profile " ^ System.fspathToPrintString filename in
let ochan =
- open_out_gen [Open_wronly; Open_append; Open_creat] 0o600 filename
+ System.open_out_gen [Open_wronly; Open_creat; Open_append] 0o600 filename
in
output_string ochan l;
output_string ochan "\n";
Modified: trunk/src/ubase/prefs.mli
===================================================================
--- trunk/src/ubase/prefs.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/ubase/prefs.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -32,6 +32,13 @@
-> string (* full (tex) documentation string *)
-> string t (* -> new preference value *)
+val createFspath :
+ string (* preference name *)
+ -> System.fspath (* initial value *)
+ -> string (* documentation string *)
+ -> string (* full (tex) documentation string *)
+ -> System.fspath t (* -> new preference value *)
+
val createStringList :
string (* preference name *)
-> string (* documentation string *)
@@ -81,7 +88,7 @@
val profileName : string option ref
(* Calculate the full pathname of a preference file *)
-val profilePathname : string -> string
+val profilePathname : string -> System.fspath
(* Add a new preference to the file on disk (the result is a diagnostic *)
(* message that can be displayed to the user to verify where the new pref *)
Modified: trunk/src/ubase/trace.ml
===================================================================
--- trunk/src/ubase/trace.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/ubase/trace.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -112,7 +112,7 @@
on a file."
let logfile =
- Prefs.createString "logfile"
+ Prefs.createFspath "logfile"
(Util.fileInHomeDir "unison.log")
"!logfile name"
"By default, logging messages will be appended to the file
@@ -127,7 +127,7 @@
None ->
let file = Prefs.read logfile in
let ch =
- open_out_gen [Open_wronly; Open_append; Open_creat] 0o600 file in
+ System.open_out_gen [Open_wronly; Open_creat; Open_append] 0o600 file in
logch := Some (ch, file);
ch
| Some(ch, file) ->
Modified: trunk/src/ubase/uarg.ml
===================================================================
--- trunk/src/ubase/uarg.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/ubase/uarg.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -44,10 +44,11 @@
let current = ref 0;;
let parse speclist anonfun errmsg =
+ let argv = System.argv () in
let initpos = !current in
let stop error =
let progname =
- if initpos < Array.length Sys.argv then Sys.argv.(initpos) else "(?)" in
+ if initpos < Array.length argv then argv.(initpos) else "(?)" in
begin match error with
| Unknown s when s = "-help" -> ()
| Unknown s ->
@@ -63,10 +64,10 @@
usage speclist errmsg;
exit 2;
in
- let l = Array.length Sys.argv in
+ let l = Array.length argv in
incr current;
while !current < l do
- let ss = Sys.argv.(!current) in
+ let ss = argv.(!current) in
if String.length ss >= 1 & String.get ss 0 = '-' then begin
let args = Util.splitIntoWords ss '=' in
let s = Safelist.nth args 0 in
@@ -74,7 +75,7 @@
match args with
[_] ->
if !current + 1 >= l then stop (Missing s) else
- let a = Sys.argv.(!current+1) in
+ let a = argv.(!current+1) in
incr current;
(try conv a with Failure _ -> stop (Wrong (s, a, mesg)))
| [_;a] -> (try conv a with Failure _ -> stop (Wrong (s, a, mesg)))
@@ -98,7 +99,7 @@
| Float f -> f (arg float_of_string "a float")
| Rest f ->
while !current < l-1 do
- f Sys.argv.(!current+1);
+ f argv.(!current+1);
incr current;
done;
with Bad m -> stop (Message m);
Modified: trunk/src/ubase/util.ml
===================================================================
--- trunk/src/ubase/util.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/ubase/util.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -257,7 +257,7 @@
convertUnixErrorsToFatal
"querying environment"
(fun () ->
- try Unix.getenv var
+ try System.getenv var
with Not_found ->
raise (Fatal ("Environment variable " ^ var ^ " not found")))
@@ -423,22 +423,23 @@
(* Building pathnames in the user's home dir *)
(*****************************************************************************)
-let fileInHomeDir n =
- if (osType = `Unix) || isCygwin then
- Filename.concat (safeGetenv "HOME") n
- else if osType = `Win32 then
- let dirString =
- try Unix.getenv "HOME" (* Windows 9x with Cygwin HOME set *)
- with Not_found ->
- try Unix.getenv "USERPROFILE" (* Windows NT/2K standard *)
- with Not_found ->
- try Unix.getenv "UNISON" (* Use UNISON dir if it is set *)
- with Not_found ->
- "c:/" (* Default *) in
- Filename.concat dirString n
- else
- assert false (* osType can't be anything else *)
+let homeDir () =
+ System.fspathFromString
+ (if (osType = `Unix) || isCygwin then
+ safeGetenv "HOME"
+ else if osType = `Win32 then
+ try System.getenv "HOME" (* Windows 9x with Cygwin HOME set *)
+ with Not_found ->
+ try System.getenv "USERPROFILE" (* Windows NT/2K standard *)
+ with Not_found ->
+ try System.getenv "UNISON" (* Use UNISON dir if it is set *)
+ with Not_found ->
+ "c:/" (* Default *)
+ else
+ assert false (* osType can't be anything else *))
+let fileInHomeDir n = System.fspathConcat (homeDir ()) n
+
(*****************************************************************************)
(* "Upcall" for building pathnames in the .unison dir *)
(*****************************************************************************)
Modified: trunk/src/ubase/util.mli
===================================================================
--- trunk/src/ubase/util.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/ubase/util.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -77,7 +77,7 @@
int (* percentage of total *)
val monthname : int -> string
val percent2string : float -> string
-val fileInHomeDir : string -> string
+val fileInHomeDir : string -> System.fspath
(* Just like the versions in the Unix module, but raising Transient
instead of Unix_error *)
@@ -96,9 +96,9 @@
(* Someone should supply a function here that will convert a simple filename
to a filename in the unison directory *)
-val supplyFileInUnisonDirFn : (string -> string) -> unit
+val supplyFileInUnisonDirFn : (string -> System.fspath) -> unit
(* Use it like this: *)
-val fileInUnisonDir : string -> string
+val fileInUnisonDir : string -> System.fspath
(* Printing and formatting functions *)
Modified: trunk/src/uicommon.ml
===================================================================
--- trunk/src/uicommon.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uicommon.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -492,7 +492,7 @@
(* If the profile does not exist, create an empty one (this should only
happen if the profile is 'default', since otherwise we will already
have checked that the named one exists). *)
- if not(Sys.file_exists (Prefs.profilePathname profileName)) then
+ if not(System.file_exists (Prefs.profilePathname profileName)) then
Prefs.addComment "Unison preferences file";
(* Load the profile *)
@@ -663,7 +663,7 @@
let profileName =
begin match !clprofile with
None ->
- let dirString = Fspath.toString Os.unisonDir in
+ let dirString = Os.unisonDir in
let profiles_exist = (Files.ls dirString "*.prf")<>[] in
let clroots_given = (Globals.rawRoots() <> []) in
let n =
@@ -683,8 +683,9 @@
n
| Some n ->
let f = Prefs.profilePathname n in
- if not(Sys.file_exists f)
- then (reportError (Printf.sprintf "Profile %s does not exist" f);
+ if not(System.file_exists f)
+ then (reportError (Printf.sprintf "Profile %s does not exist"
+ (System.fspathToPrintString f));
exit 1);
n
end in
Modified: trunk/src/uigtk.ml
===================================================================
--- trunk/src/uigtk.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uigtk.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -758,8 +758,7 @@
(f, info))
(Safelist.filter (fun name -> not ( Util.startswith name ".#"
|| Util.startswith name Os.tempFilePrefix))
- (Files.ls (Fspath.toString Os.unisonDir)
- "*.prf")))
+ (Files.ls Os.unisonDir "*.prf")))
let getProfile () =
(* The selected profile *)
@@ -852,7 +851,7 @@
let profile = prof#text in
if profile <> "" then
let filename = Prefs.profilePathname profile in
- if Sys.file_exists filename then
+ if System.file_exists filename then
okBox
~title:(Uutil.myName ^ " error")
~message:("Profile \""
@@ -861,7 +860,7 @@
else
(* Make an empty file *)
let ch =
- open_out_gen
+ System.open_out_gen
[Open_wronly; Open_creat; Open_trunc] 0o600 filename in
close_out ch;
fillLst profile;
@@ -2020,7 +2019,7 @@
grAdd grRestart
(fileMenu#add_item ~key:key
~callback:(fun _ ->
- if Sys.file_exists (Prefs.profilePathname name) then begin
+ if System.file_exists (Prefs.profilePathname name) then begin
Trace.status ("Loading profile " ^ name);
loadProfile name; detectCmd()
end else
@@ -2146,7 +2145,7 @@
let displayAvailable =
Util.osType = `Win32
||
- try Unix.getenv "DISPLAY" <> "" with Not_found -> false
+ try System.getenv "DISPLAY" <> "" with Not_found -> false
in
if displayAvailable then Private.start Uicommon.Graphic
else Uitext.Body.start Uicommon.Text
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uigtk2.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -170,7 +170,7 @@
non-ASCII characters. *)
let code =
- [| 0x0000; 0x0001; 0x0002; 0x0003; 0x0004; 0x0005; 0x0006; 0x0007;
+ [| 0x0020; 0x0001; 0x0002; 0x0003; 0x0004; 0x0005; 0x0006; 0x0007;
0x0008; 0x0009; 0x000A; 0x000B; 0x000C; 0x000D; 0x000E; 0x000F;
0x0010; 0x0011; 0x0012; 0x0013; 0x0014; 0x0015; 0x0016; 0x0017;
0x0018; 0x0019; 0x001A; 0x001B; 0x001C; 0x001D; 0x001E; 0x001F;
@@ -227,7 +227,7 @@
(****)
let wf_utf8 =
- [[('\x00', '\x7F')];
+ [[('\x01', '\x7F')];
[('\xC2', '\xDF'); ('\x80', '\xBF')];
[('\xE0', '\xE0'); ('\xA0', '\xBF'); ('\x80', '\xBF')];
[('\xE1', '\xEC'); ('\x80', '\xBF'); ('\x80', '\xBF')];
@@ -273,7 +273,9 @@
(****)
let protect_char buf c =
- if c < '\x80' then
+ if c = '\x00' then
+ Buffer.add_char buf ' '
+ else if c < '\x80' then
Buffer.add_char buf c
else
let c = Char.code c in
@@ -303,13 +305,18 @@
let escapeMarkup s = Glib.Markup.escape_text s
let transcode s =
+ if Prefs.read Case.unicodeEncoding then
+ protect s
+ else
try
Glib.Convert.locale_to_utf8 s
with Glib.Convert.Error _ ->
protect s
let transcodeFilename s =
- if Util.osType = `Win32 then transcode s else
+ if Prefs.read Case.unicodeEncoding then
+ protect s
+ else if Util.osType = `Win32 then transcode s else
try
Glib.Convert.filename_to_utf8 s
with Glib.Convert.Error _ ->
@@ -901,16 +908,17 @@
None -> profileKeymap.(i) <- Some(profile,info)
| Some(otherProfile,_) ->
raise (Util.Fatal
- ("Error scanning profile "^filename^":\n"
+ ("Error scanning profile "^
+ System.fspathToPrintString filename ^":\n"
^ "shortcut key "^k^" is already bound to profile "
^ otherProfile))
else
raise (Util.Fatal
- ("Error scanning profile "^filename^":\n"
+ ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
with int_of_string -> raise (Util.Fatal
- ("Error scanning profile "^filename^":\n"
+ ("Error scanning profile "^ System.fspathToPrintString filename ^":\n"
^ "Value of 'key' preference must be a single digit (0-9), "
^ "not " ^ k))
@@ -941,8 +949,7 @@
(f, info))
(Safelist.filter (fun name -> not ( Util.startswith name ".#"
|| Util.startswith name Os.tempFilePrefix))
- (Files.ls (Fspath.toString Os.unisonDir)
- "*.prf")))
+ (Files.ls Os.unisonDir "*.prf")))
let getProfile () =
(* The selected profile *)
@@ -1038,7 +1045,7 @@
let profile = prof#text in
if profile <> "" then
let filename = Prefs.profilePathname profile in
- if Sys.file_exists filename then
+ if System.file_exists filename then
okBox
~title:"Error" ~typ:`ERROR
~message:("Profile \""
@@ -1047,8 +1054,8 @@
else
(* Make an empty file *)
let ch =
- open_out_gen
- [Open_wronly; Open_creat; Open_trunc] 0o600 filename in
+ System.open_out_gen
+ [Open_wronly; Open_creat; Open_excl] 0o600 filename in
close_out ch;
fillLst profile;
exit () in
@@ -1585,9 +1592,11 @@
let greenPixel = "00dd00" in
let redPixel = "ff2040" in
+ let lightbluePixel = "8888FF" in
+(*
let yellowPixel = "999900" in
- let lightbluePixel = "8888FF" in
let blackPixel = "000000" in
+*)
let buildPixmap p =
GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:p () in
let buildPixmaps f c1 =
@@ -1598,10 +1607,12 @@
let ignoreAct = buildPixmaps Pixmaps.ignore redPixel in
let doneIcon = buildPixmap Pixmaps.success in
let failedIcon = buildPixmap Pixmaps.failure in
+ let mergeLogo = buildPixmaps Pixmaps.mergeLogo greenPixel in
+(*
let rightArrowBlack = buildPixmap (Pixmaps.copyAB blackPixel) in
let leftArrowBlack = buildPixmap (Pixmaps.copyBA blackPixel) in
- let mergeLogo = buildPixmaps Pixmaps.mergeLogo greenPixel in
let mergeLogoBlack = buildPixmap (Pixmaps.mergeLogo blackPixel) in
+*)
let displayArrow i j action =
let changedFromDefault = match !theState.(j).ri.replicas with
@@ -2362,7 +2373,7 @@
grAdd grRestart
(fileMenu#add_item ~key:key
~callback:(fun _ ->
- if Sys.file_exists (Prefs.profilePathname name) then begin
+ if System.file_exists (Prefs.profilePathname name) then begin
Trace.status ("Loading profile " ^ name);
loadProfile name; detectCmd ()
end else
@@ -2496,7 +2507,7 @@
let displayAvailable =
Util.osType = `Win32
||
- try Unix.getenv "DISPLAY" <> "" with Not_found -> false
+ try System.getenv "DISPLAY" <> "" with Not_found -> false
in
if displayAvailable then Private.start Uicommon.Graphic
else Uitext.Body.start Uicommon.Text
Modified: trunk/src/uimacbridge.ml
===================================================================
--- trunk/src/uimacbridge.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uimacbridge.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -18,7 +18,7 @@
mutable statusMessage : string option };;
let theState = ref [| |];;
-let unisonDirectory() = Fspath.toString Os.unisonDir
+let unisonDirectory() = System.fspathToPrintString Os.unisonDir
;;
Callback.register "unisonDirectory" unisonDirectory;;
@@ -61,7 +61,7 @@
this in Util just because the Prefs module lives below the Os module in the
dependency hierarchy, so Prefs can't call Os directly.) *)
Util.supplyFileInUnisonDirFn
- (fun n -> Fspath.toString (Os.fileInUnisonDir(n)));
+ (fun n -> Os.fileInUnisonDir(n));
(* Display status in GUI instead of on stderr *)
let formatStatus major minor = (Util.padto 30 (major ^ " ")) ^ minor in
Trace.messageDisplayer := displayStatus;
@@ -107,8 +107,9 @@
None -> ()
| Some n ->
let f = Prefs.profilePathname n in
- if not(Sys.file_exists f)
- then (Printf.eprintf "Profile %s does not exist" f;
+ if not(System.file_exists f)
+ then (Printf.eprintf "Profile %s does not exist"
+ (System.fspathToPrintString f);
exit 1)
end;
!clprofile
@@ -132,7 +133,7 @@
(* If the profile does not exist, create an empty one (this should only
happen if the profile is 'default', since otherwise we will already
have checked that the named one exists). *)
- if not(Sys.file_exists (Prefs.profilePathname profileName)) then
+ if not(System.file_exists (Prefs.profilePathname profileName)) then
Prefs.addComment "Unison preferences file";
(* Load the profile *)
Modified: trunk/src/uimacbridgenew.ml
===================================================================
--- trunk/src/uimacbridgenew.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uimacbridgenew.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -18,7 +18,7 @@
mutable statusMessage : string option };;
let theState = ref [| |];;
-let unisonDirectory() = Fspath.toString Os.unisonDir
+let unisonDirectory() = System.fspathToPrintString Os.unisonDir
;;
Callback.register "unisonDirectory" unisonDirectory;;
@@ -107,7 +107,7 @@
this in Util just because the Prefs module lives below the Os module in the
dependency hierarchy, so Prefs can't call Os directly.) *)
Util.supplyFileInUnisonDirFn
- (fun n -> Fspath.toString (Os.fileInUnisonDir(n)));
+ (fun n -> Os.fileInUnisonDir(n));
(* Display status in GUI instead of on stderr *)
let formatStatus major minor = (Util.padto 30 (major ^ " ")) ^ minor in
Trace.messageDisplayer := displayStatus;
@@ -155,8 +155,9 @@
None -> ()
| Some n ->
let f = Prefs.profilePathname n in
- if not(Sys.file_exists f)
- then (Printf.eprintf "Profile %s does not exist" f;
+ if not(System.file_exists f)
+ then (Printf.eprintf "Profile %s does not exist"
+ (System.fspathToPrintString f);
exit 1)
end;
!clprofile
@@ -180,7 +181,7 @@
(* If the profile does not exist, create an empty one (this should only
happen if the profile is 'default', since otherwise we will already
have checked that the named one exists). *)
- if not(Sys.file_exists (Prefs.profilePathname profileName)) then
+ if not(System.file_exists (Prefs.profilePathname profileName)) then
Prefs.addComment "Unison preferences file";
(* Load the profile *)
Modified: trunk/src/uitext.ml
===================================================================
--- trunk/src/uitext.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uitext.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -27,7 +27,7 @@
Prefs.createBool "dumbtty"
(match Util.osType with
`Unix ->
- (try (Unix.getenv "EMACS" <> "") with
+ (try (System.getenv "EMACS" <> "") with
Not_found -> false)
| _ ->
true)
@@ -215,7 +215,7 @@
begin match !Prefs.profileName with None -> assert false |
Some(n) ->
display (" To un-ignore, edit "
- ^ (Prefs.profilePathname n)
+ ^ System.fspathToPrintString (Prefs.profilePathname n)
^ " and restart " ^ Uutil.myName ^ "\n") end;
let nukeIgnoredRis =
Safelist.filter (fun ri -> not (Globals.shouldIgnore ri.path)) in
@@ -284,7 +284,7 @@
Uicommon.showDiffs ri
(fun title text ->
try
- let pager = Sys.getenv "PAGER" in
+ let pager = System.getenv "PAGER" in
restoreTerminal ();
let out = Unix.open_process_out pager in
Printf.fprintf out "\n%s\n\n%s\n\n" title text;
@@ -614,7 +614,8 @@
let suckOnWatcherFileLocal n =
Util.convertUnixErrorsToFatal
- ("Reading changes from watcher process in file " ^ n)
+ ("Reading changes from watcher process in file " ^
+ System.fspathToPrintString n)
(fun () ->
(* The main loop, invoked from two places below *)
let rec loop ch =
@@ -636,15 +637,15 @@
(* Make sure there's a file to watch, then read from it *)
match !watcherchan with
None ->
- if Sys.file_exists n then begin
- let ch = open_in n in
+ if System.file_exists n then begin
+ let ch = System.open_in_bin n in
watcherchan := Some(ch);
loop ch
end else []
| Some(ch) -> loop ch
)
-let suckOnWatcherFileRoot: Common.root -> string -> (string list) Lwt.t =
+let suckOnWatcherFileRoot: Common.root -> System.fspath -> (string list) Lwt.t =
Remote.registerRootCmd
"suckOnWatcherFile"
(fun (fspath, n) ->
@@ -656,7 +657,7 @@
Globals.allRootsMap (fun r -> suckOnWatcherFileRoot r n)))
let synchronizePathsFromFilesystemWatcher () =
- let watcherfilename = "" in
+ let watcherfilename = System.fspathFromString "" in
(* STOPPED HERE -- need to find the program using watcherosx preference and invoke it using a redirect to get the output into a temp file... *)
let rec loop failedPaths =
let newpaths = suckOnWatcherFiles watcherfilename in
Modified: trunk/src/unicode.ml
===================================================================
--- trunk/src/unicode.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/unicode.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -775,7 +775,7 @@
cont s' j s (i + 4) l v
end
end else
- String.sub s' 0 j
+ String.sub s' 0 (j + 2)
and cont s' j s i l v =
if v < 0x10000 then begin
@@ -790,7 +790,7 @@
let to_utf_16 s =
let l = String.length s in
- let s' = String.create (2 * l) in
+ let s' = String.make (2 * l + 2) '\000' in
scan s' 0 s 0 l
(****)
@@ -798,21 +798,29 @@
let rec scan s' i' l' s i l =
if i + 2 <= l then begin
let v = get_2 s i in
- if v < 0xD800 || v > 0xDFFF then
+ if v = 0 then
+ String.sub s' 0 i' (* null *)
+ else if v < 0xD800 || v > 0xDFFF then
let i' = encode_char s' i' l' v in
scan s' i' l' s (i + 2) l
else if v >= 0xdc00 || i + 4 > l then
- fail ()
+ let i' = encode_char s' i' l' v in
+ scan s' i' l' s (i + 2) l
+(* fail () *)
else begin
let v' = get_2 s (i + 2) in
- if v' < 0xDC00 || v' > 0XDFFF then fail () else
- let i' =
- encode_char s' i' l' ((v - 0xD800) lsl 10 + (v' - 0xDC00) + 0x10000)
- in
- scan s' i' l' s (i + 4) l
+ if v' < 0xDC00 || v' > 0XDFFF then
+ let i' = encode_char s' i' l' v in
+ scan s' i' l' s (i + 2) l
+(* fail ()*)
+ else
+ let i' =
+ encode_char s' i' l' ((v - 0xD800) lsl 10 + (v' - 0xDC00) + 0x10000)
+ in
+ scan s' i' l' s (i + 4) l
end
end else if i < l then
- fail ()
+ fail () (* Odd number of chars *)
else
String.sub s' 0 i'
@@ -842,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 >= 0x800 && (v < 0xd800 || v > 0xdfff) &&
scan s (i + 3) l
end else begin
(* 10000 - 10FFFF *)
Modified: trunk/src/unicode.mli
===================================================================
--- trunk/src/unicode.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/unicode.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -14,8 +14,9 @@
by Mac OS X. *)
val compose : string -> string
-(* Convert to and from little-endian UTF-16 encoding *)
-(*XXX What about null-termination? *)
+(* Convert to and from a null-terminated little-endian UTF-16 string *)
+(* Do not fail on isolated surrogate but rather generate ill-formed
+ UTF-8 characters, so that the conversion never fails. *)
val to_utf_16 : string -> string
val from_utf_16 : string -> string
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/update.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -265,13 +265,13 @@
(* Load in the archive in [fspath]; check that archiveFormat (first line)
and roots (second line) match skip the third line (time stamp), and read
in the archive *)
-let loadArchiveLocal (fspath: Fspath.t) (thisRoot: string) :
+let loadArchiveLocal fspath (thisRoot: string) :
(archive * int * string) option =
- let f = Fspath.toString fspath in
- debug (fun() -> Util.msg "Loading archive from %s\n" f);
+ debug (fun() ->
+ Util.msg "Loading archive from %s\n" (System.fspathToDebugString fspath));
Util.convertUnixErrorsToFatal "loading archive" (fun () ->
- if Sys.file_exists f then
- let c = open_in_bin f in
+ if System.file_exists fspath then
+ let c = System.open_in_bin fspath in
let header = input_line c in
(* Sanity check on archive format *)
if header<>formatString then begin
@@ -306,16 +306,19 @@
"Archive file seems damaged (%s): \
throw away archives on both machines and try again" s))
else
- (debug (fun() -> Util.msg "Archive %s not found\n" f);
+ (debug (fun() ->
+ Util.msg "Archive %s not found\n"
+ (System.fspathToDebugString fspath));
None))
(* Inverse to loadArchiveLocal *)
let storeArchiveLocal fspath thisRoot archive hash magic =
- let f = Fspath.toString fspath in
- debug (fun() -> Util.msg "Saving archive in %s\n" f);
+ debug (fun() ->
+ Util.msg "Saving archive in %s\n" (System.fspathToDebugString fspath));
Util.convertUnixErrorsToFatal "saving archive" (fun () ->
let c =
- open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 f
+ System.open_out_gen
+ [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 fspath
in
output_string c formatString;
output_string c "\n";
@@ -330,10 +333,11 @@
let removeArchiveLocal ((fspath: Fspath.t), (v: archiveVersion)): unit Lwt.t =
Lwt.return
(let (name,_) = archiveName fspath v in
- let f = Fspath.toString (Os.fileInUnisonDir name) in
- debug (fun() -> Util.msg "Removing archive %s\n" f);
+ let fspath = Os.fileInUnisonDir name in
+ debug (fun() ->
+ Util.msg "Removing archive %s\n" (System.fspathToDebugString fspath));
Util.convertUnixErrorsToFatal "removing archive" (fun () ->
- if Sys.file_exists f then Sys.remove f))
+ if System.file_exists fspath then System.unlink fspath))
(* [removeArchiveOnRoot root v] invokes [removeArchive fspath v] on the
server, where [fspath] is the path to root on the server *)
@@ -347,11 +351,11 @@
Lwt.return
(let (fromname,_) = archiveName fspath ScratchArch in
let (toname,_) = archiveName fspath NewArch in
- let ffrom = Fspath.toString (Os.fileInUnisonDir fromname) in
- let fto = Fspath.toString (Os.fileInUnisonDir toname) in
+ let ffrom = Os.fileInUnisonDir fromname in
+ let fto = Os.fileInUnisonDir toname in
Util.convertUnixErrorsToFatal
"committing"
- (fun () -> Unix.rename ffrom fto))
+ (fun () -> System.rename ffrom fto))
(* [commitArchiveOnRoot root v] invokes [commitArchive fspath v] on the
server, where [fspath] is the path to root on the server *)
@@ -366,20 +370,23 @@
Lwt.return
(let (fromname,_) = archiveName fspath NewArch in
let (toname, thisRoot) = archiveName fspath MainArch in
- let ffrom = Fspath.toString (Os.fileInUnisonDir fromname) in
- let fto = Fspath.toString (Os.fileInUnisonDir toname) in
- debug (fun() -> Util.msg "Copying archive %s to %s\n" ffrom fto);
+ let ffrom = Os.fileInUnisonDir fromname in
+ let fto = Os.fileInUnisonDir toname in
+ debug (fun() ->
+ Util.msg "Copying archive %s to %s\n"
+ (System.fspathToDebugString ffrom)
+ (System.fspathToDebugString fto));
Util.convertUnixErrorsToFatal "copying archive" (fun () ->
let outFd =
- open_out_gen
+ System.open_out_gen
[Open_wronly; Open_creat; Open_trunc; Open_binary] 0o600 fto in
- Unix.chmod fto 0o600; (* In case the file already existed *)
- let inFd = open_in_gen [Open_rdonly; Open_binary] 0o444 ffrom in
+ System.chmod fto 0o600; (* In case the file already existed *)
+ let inFd = System.open_in_bin ffrom in
Uutil.readWrite inFd outFd (fun _ -> ());
close_in inFd;
close_out outFd;
let arcFspath = Os.fileInUnisonDir toname in
- let info = Fileinfo.get false arcFspath Path.empty in
+ let info = Fileinfo.get' arcFspath in
Hashtbl.replace archiveInfoCache thisRoot info))
(* [postCommitArchiveOnRoot root v] invokes [postCommitArchive fspath v] on
@@ -450,8 +457,9 @@
let (name, root) = archiveName fspath MainArch in
let archive = getArchive root in
let f = Util.fileInHomeDir "unison.dump" in
- debug (fun () -> Printf.eprintf "Dumping archive into `%s'\n" f);
- let ch = open_out_gen [Open_wronly; Open_trunc; Open_creat] 0o600 f in
+ debug (fun () -> Printf.eprintf "Dumping archive into `%s'\n"
+ (System.fspathToDebugString f));
+ let ch = System.open_out_gen [Open_wronly; Open_creat; Open_trunc] 0o600 f in
let (outfn,flushfn) = Format.get_formatter_output_functions () in
Format.set_formatter_out_channel ch;
Format.printf "Contents of archive for %s\n" root;
@@ -483,17 +491,17 @@
(* If the archive is not in a stable state, we need to
perform archive recovery. So, the optimistic loading
fails. *)
- Sys.file_exists (Fspath.toString (Os.fileInUnisonDir newArcName))
+ Sys.file_exists newArcName
||
let (lockFilename, _) = archiveName fspath Lock in
- let lockFile = Fspath.toString (Os.fileInUnisonDir lockFilename) in
+ let lockFile = Os.fileInUnisonDir lockFilename in
Lock.is_locked lockFile
then
Lwt.return None
else
let (arcName,thisRoot) = archiveName fspath MainArch in
let arcFspath = Os.fileInUnisonDir arcName in
- let info = Fileinfo.get false arcFspath Path.empty in
+ let info = Fileinfo.get' arcFspath in
if archiveUnchanged fspath info then
(* The archive is unchanged. So, we don't need to do
anything. *)
@@ -501,7 +509,7 @@
else begin
match loadArchiveLocal arcFspath thisRoot with
Some (arch, hash, magic) ->
- let info' = Fileinfo.get false arcFspath Path.empty in
+ let info' = Fileinfo.get' arcFspath in
if fileUnchanged info info' then begin
setArchiveLocal thisRoot arch;
Hashtbl.replace archiveInfoCache thisRoot info;
@@ -517,7 +525,7 @@
match loadArchiveLocal arcFspath thisRoot with
Some (arch, hash, magic) ->
setArchiveLocal thisRoot arch;
- let info = Fileinfo.get false arcFspath Path.empty in
+ let info = Fileinfo.get' arcFspath in
Hashtbl.replace archiveInfoCache thisRoot info;
Lwt.return (Some (hash, magic))
| None ->
@@ -551,7 +559,8 @@
^ " b) Move the archive files on each machine to some other directory\n"
^ " (in case they may be useful for debugging).\n"
^ " The archive files on this machine are in the directory\n"
- ^ (Printf.sprintf " %s\n" (Fspath.toString Os.unisonDir))
+ ^ (Printf.sprintf " %s\n"
+ (System.fspathToPrintString Os.unisonDir))
^ " and have names of the form\n"
^ " arXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\n"
^ " where the X's are a hexidecimal number .\n"
@@ -641,12 +650,12 @@
let lockArchiveLocal fspath =
let (lockFilename, _) = archiveName fspath Lock in
- let lockFile = Fspath.toString (Os.fileInUnisonDir lockFilename) in
+ let lockFile = Os.fileInUnisonDir lockFilename in
if Lock.acquire lockFile then
None
else
Some (Printf.sprintf "The file %s on host %s should be deleted"
- lockFile Os.myCanonicalHostName)
+ (System.fspathToPrintString lockFile) Os.myCanonicalHostName)
let lockArchiveOnRoot: Common.root -> unit -> string option Lwt.t =
Remote.registerRootCmd
@@ -654,7 +663,7 @@
let unlockArchiveLocal fspath =
Lock.release
- (Fspath.toString (Os.fileInUnisonDir (fst (archiveName fspath Lock))))
+ (Os.fileInUnisonDir (fst (archiveName fspath Lock)))
let unlockArchiveOnRoot: Common.root -> unit -> unit Lwt.t =
Remote.registerRootCmd
@@ -746,10 +755,10 @@
(fun (fspath,rootsName) ->
let (oldname,_) = archiveName fspath MainArch in
let oldexists =
- Sys.file_exists (Fspath.toString (Os.fileInUnisonDir oldname)) in
+ System.file_exists (Os.fileInUnisonDir oldname) in
let (newname,_) = archiveName fspath NewArch in
let newexists =
- Sys.file_exists (Fspath.toString (Os.fileInUnisonDir newname)) in
+ System.file_exists (Os.fileInUnisonDir newname) in
Lwt.return (oldexists, newexists))
let (archiveNameOnRoot
@@ -762,7 +771,7 @@
Lwt.return
(name,
Os.myCanonicalHostName,
- Sys.file_exists (Fspath.toString (Os.fileInUnisonDir name))))
+ System.file_exists (Os.fileInUnisonDir name)))
let forall = Safelist.for_all (fun x -> x)
let exists = Safelist.exists (fun x -> x)
@@ -863,7 +872,7 @@
debugverbose
(fun() ->
Printf.eprintf "updatePathInArchive %s %s [%s] [%s]\n"
- (archive2string archive) (Fspath.toString fspath)
+ (archive2string archive) (Fspath.toDebugString fspath)
(Path.toString here) (Path.toString rest));
match Path.deconstruct rest with
None ->
@@ -926,7 +935,7 @@
let isDir fspath path =
let fullFspath = Fspath.concat fspath path in
try
- (Fspath.stat fullFspath).Unix.LargeFile.st_kind = Unix.S_DIR
+ (Fs.stat fullFspath).Unix.LargeFile.st_kind = Unix.S_DIR
with Unix.Unix_error _ -> false
(***********************************************************************
@@ -949,7 +958,7 @@
if not (Os.exists fspath path) then
raise (Util.Fatal
(Printf.sprintf "Path %s / %s is designated as a mountpoint, but points to nothing on host %s\n"
- (Fspath.toString fspath) (Path.toString path) Os.myCanonicalHostName)))
+ (Fspath.toPrintString fspath) (Path.toString path) Os.myCanonicalHostName)))
(Prefs.read mountpoints)
@@ -1341,7 +1350,7 @@
try
debug (fun() ->
Util.msg "buildUpdate: %s\n"
- (Fspath.concatToString currfspath path));
+ (Fspath.toDebugString (Fspath.concat currfspath path)));
let info = Fileinfo.get true currfspath path in
match (info.Fileinfo.typ, archive) with
(`ABSENT, NoArchive) ->
@@ -1512,7 +1521,7 @@
items; as a side effect, update the local archive w.r.t. time-stamps for
unchanged files *)
let findLocal fspath pathList: Common.updateItem list =
- debug (fun() -> Util.msg "findLocal %s\n" (Fspath.toString fspath));
+ debug (fun() -> Util.msg "findLocal %s\n" (Fspath.toDebugString fspath));
addHashToTempNames fspath;
(* Maybe we should remember the device number where the root lives at
the beginning of update detection, so that we can check, below, that
@@ -1721,7 +1730,7 @@
let updateArchiveLocal fspath path ui id =
debug (fun() ->
Util.msg "updateArchiveLocal %s %s\n"
- (Fspath.toString fspath) (Path.toString path));
+ (Fspath.toDebugString fspath) (Path.toString path));
let root = thisRootsGlobalName fspath in
let archive = getArchive root in
let (localPath, subArch) = getPathInArchive archive Path.empty path in
@@ -1756,7 +1765,7 @@
(fun path uc ->
debug (fun() ->
Util.msg "markEqualLocal %s %s\n"
- (Fspath.toString fspath) (Path.toString path));
+ (Fspath.toDebugString fspath) (Path.toString path));
let arch, (subArch, localPath) =
updatePathInArchive !archive fspath Path.empty path
(fun archive _ localPath ->
@@ -1824,7 +1833,7 @@
let replaceArchiveLocal fspath pathTo location arch id paranoid deleteBadTempFiles =
debug (fun() -> Util.msg
"replaceArchiveLocal %s %s\n"
- (Fspath.toString fspath)
+ (Fspath.toDebugString fspath)
(Path.toString pathTo)
);
let root = thisRootsGlobalName fspath in
@@ -1901,7 +1910,7 @@
let updatePropsLocal fspath path propOpt ui id =
debug (fun() ->
Util.msg "updatePropsLocal %s %s\n"
- (Fspath.toString fspath) (Path.toString path));
+ (Fspath.toDebugString fspath) (Path.toString path));
let root = thisRootsGlobalName fspath in
let commit () =
let archive = getArchive root in
@@ -1929,7 +1938,7 @@
let checkNoUpdatesLocal fspath pathInArchive ui =
debug (fun() ->
Util.msg "checkNoUpdatesLocal %s %s\n"
- (Fspath.toString fspath) (Path.toString pathInArchive));
+ (Fspath.toDebugString fspath) (Path.toString pathInArchive));
let archive = getArchive (thisRootsGlobalName fspath) in
let (localPath, archive) =
getPathInArchive archive Path.empty pathInArchive in
Modified: trunk/src/uutil.ml
===================================================================
--- trunk/src/uutil.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uutil.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -141,3 +141,17 @@
notify !l
in
Util.convertUnixErrorsToTransient "readWriteBounded" (fun () -> read len)
+
+(*****************************************************************************)
+(* ESCAPING SHELL PARAMETERS *)
+(*****************************************************************************)
+
+(* Using single quotes is simpler under Unix but they are not accepted
+ by the Windows shell. Double quotes without further quoting is
+ sufficient with Windows as filenames are not allowed to contain
+ double quotes. *)
+let quotes s =
+ if Util.osType = `Win32 && not Util.isCygwin then
+ "\"" ^ s ^ "\""
+ else
+ "'" ^ Util.replacesubstring s "'" "'\\''" ^ "'"
Modified: trunk/src/uutil.mli
===================================================================
--- trunk/src/uutil.mli 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/uutil.mli 2009-05-13 18:02:17 UTC (rev 331)
@@ -63,3 +63,6 @@
-> Filesize.t
-> (int -> unit) (* progress notification *)
-> unit
+
+(* Escape shell parameters *)
+val quotes : string -> string
Modified: trunk/src/xferhint.ml
===================================================================
--- trunk/src/xferhint.ml 2009-05-07 10:01:25 UTC (rev 330)
+++ trunk/src/xferhint.ml 2009-05-13 18:02:17 UTC (rev 331)
@@ -32,7 +32,7 @@
(struct
type t = Fspath.t * Path.local
let hash (fspath, path) =
- (Hashtbl.hash (Fspath.toString fspath) + 13217 * Path.hash path)
+ (Fspath.hash fspath + 13217 * Path.hash path)
land
0x3FFFFFFF
let equal = (=)
@@ -71,7 +71,7 @@
debug (fun () ->
let (fspath, path) = p in
Util.msg "insertEntry: fspath=%s, path=%s, fp=%s\n"
- (Fspath.toString fspath)
+ (Fspath.toDebugString fspath)
(Path.toString path) (Os.fullfingerprint_to_string fp));
(* Neither of these should be able to raise Not_found *)
PathMap.replace path2fingerprintMap p fp;
@@ -83,7 +83,7 @@
debug (fun () ->
let (fspath, path) = p in
Util.msg "deleteEntry: fspath=%s, path=%s\n"
- (Fspath.toString fspath) (Path.toString path));
+ (Fspath.toDebugString fspath) (Path.toString path));
try
let fp = PathMap.find path2fingerprintMap p in
PathMap.remove path2fingerprintMap p;
@@ -100,8 +100,8 @@
let (fspathOrig, pathOrig) = pOrig in
let (fspathNew, pathNew) = pNew in
Util.msg "renameEntry: fsOrig=%s, pOrig=%s, fsNew=%s, pNew=%s\n"
- (Fspath.toString fspathOrig) (Path.toString pathOrig)
- (Fspath.toString fspathNew) (Path.toString pathNew));
+ (Fspath.toDebugString fspathOrig) (Path.toString pathOrig)
+ (Fspath.toDebugString fspathNew) (Path.toString pathNew));
try
let fp = PathMap.find path2fingerprintMap pOrig in
PathMap.remove path2fingerprintMap pOrig;
More information about the Unison-hackers
mailing list