[Unison-hackers] [unison-svn] r506 - in trunk/src: . fsmonitor fsmonitor/linux fsmonitor/windows lwt lwt/win system
vouillon at seas.upenn.edu
vouillon at seas.upenn.edu
Thu Aug 9 10:30:22 EDT 2012
Author: vouillon
Date: 2012-08-09 10:30:22 -0400 (Thu, 09 Aug 2012)
New Revision: 506
Added:
trunk/src/fsmonitor/
trunk/src/fsmonitor/linux/
trunk/src/fsmonitor/linux/Makefile
trunk/src/fsmonitor/linux/inotify.ml
trunk/src/fsmonitor/linux/inotify.mli
trunk/src/fsmonitor/linux/inotify_stubs.c
trunk/src/fsmonitor/linux/lwt_inotify.ml
trunk/src/fsmonitor/linux/lwt_inotify.mli
trunk/src/fsmonitor/linux/watcher.ml
trunk/src/fsmonitor/watchercommon.ml
trunk/src/fsmonitor/watchercommon.mli
trunk/src/fsmonitor/windows/
trunk/src/fsmonitor/windows/Makefile
trunk/src/fsmonitor/windows/shortnames.ml
trunk/src/fsmonitor/windows/shortnames.mli
trunk/src/fsmonitor/windows/shortnames_stubs.c
trunk/src/fsmonitor/windows/watcher.ml
trunk/src/fswatch.ml
trunk/src/fswatch.mli
trunk/src/lwt/win/lwt_win.ml
trunk/src/lwt/win/lwt_win.mli
Modified:
trunk/src/
trunk/src/.depend
trunk/src/Makefile.OCaml
trunk/src/RECENTNEWS
trunk/src/TODO.txt
trunk/src/fileinfo.ml
trunk/src/fswatchold.ml
trunk/src/lwt/lwt_unix_stubs.c
trunk/src/lwt/win/lwt_unix_impl.ml
trunk/src/mkProjectInfo.ml
trunk/src/system/system_win_stubs.c
trunk/src/uicommon.ml
trunk/src/update.ml
Log:
* More robust file watching helper programs for Windows and Linux.
They communicate with Unison through pipes (Unison redirects stdin
and stdout), using a race-free protocol.
Property changes on: trunk/src
___________________________________________________________________
Modified: svn:ignore
- *.cmx
*.cmi
*.cmo
mkProjectInfo
unison
TAGS
Makefile.ProjectInfo
unison.tmproj
+ *.cmx
*.cmi
*.cmo
mkProjectInfo
unison
unison.exe
unison-fsmonitor
unison-fsmonitor.exe
TAGS
Makefile.ProjectInfo
unison.tmproj
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/.depend 2012-08-09 14:30:22 UTC (rev 506)
@@ -18,6 +18,7 @@
fileinfo.cmi
fs.cmi: system/system_intf.cmo fspath.cmi
fspath.cmi: system.cmi path.cmi name.cmi
+fswatch.cmi: path.cmi lwt/lwt.cmi fspath.cmi
fswatchold.cmi: path.cmi lwt/lwt.cmi fspath.cmi
globals.cmi: ubase/prefs.cmi pred.cmi path.cmi lwt/lwt.cmi common.cmi
lock.cmi: system.cmi
@@ -79,9 +80,9 @@
external.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx lwt/lwt_util.cmx \
lwt/lwt_unix.cmx lwt/lwt.cmx external.cmi
fileinfo.cmo: ubase/util.cmi system.cmi props.cmi ubase/prefs.cmi path.cmi \
- osx.cmi fspath.cmi fs.cmi fileinfo.cmi
+ osx.cmi fswatch.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
+ osx.cmx fswatch.cmx fspath.cmx fs.cmx fileinfo.cmi
files.cmo: xferhint.cmi 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 name.cmi \
@@ -112,18 +113,24 @@
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
+fswatch.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi system.cmi path.cmi \
+ lwt/lwt_unix.cmi lwt/lwt.cmi fspath.cmi fswatch.cmi
+fswatch.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx system.cmx path.cmx \
+ lwt/lwt_unix.cmx lwt/lwt.cmx fspath.cmx fswatch.cmi
fswatchold.cmo: uutil.cmi ubase/util.cmi system.cmi ubase/safelist.cmi \
ubase/prefs.cmi pred.cmi path.cmi os.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
- globals.cmi fspath.cmi fswatchold.cmi
+ globals.cmi fswatch.cmi fspath.cmi fswatchold.cmi
fswatchold.cmx: uutil.cmx ubase/util.cmx system.cmx ubase/safelist.cmx \
ubase/prefs.cmx pred.cmx path.cmx os.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
- globals.cmx fspath.cmx fswatchold.cmi
+ globals.cmx fswatch.cmx fspath.cmx fswatchold.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
globals.cmx: ubase/util.cmx ubase/trace.cmx ubase/safelist.cmx remote.cmx \
ubase/prefs.cmx pred.cmx path.cmx os.cmx name.cmx lwt/lwt_util.cmx \
lwt/lwt_unix.cmx lwt/lwt.cmx common.cmx clroot.cmx globals.cmi
+library_info.cmo:
+library_info.cmx:
linkgtk.cmo: uigtk.cmi main.cmo
linkgtk.cmx: uigtk.cmx main.cmx
linkgtk2.cmo: uigtk2.cmi main.cmo
@@ -290,20 +297,24 @@
system.cmi ubase/safelist.cmi remote.cmi props.cmi ubase/proplist.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 fswatchold.cmi \
- fspath.cmi fpcache.cmi fingerprint.cmi fileinfo.cmi common.cmi case.cmi \
- update.cmi
+ fswatch.cmi fspath.cmi fpcache.cmi fingerprint.cmi fileinfo.cmi \
+ common.cmi case.cmi update.cmi
update.cmx: xferhint.cmx uutil.cmx ubase/util.cmx tree.cmx ubase/trace.cmx \
system.cmx ubase/safelist.cmx remote.cmx props.cmx ubase/proplist.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 fswatchold.cmx \
- fspath.cmx fpcache.cmx fingerprint.cmx fileinfo.cmx common.cmx case.cmx \
- update.cmi
-uutil.cmo: ubase/util.cmi ubase/trace.cmi ubase/projectInfo.cmo uutil.cmi
-uutil.cmx: ubase/util.cmx ubase/trace.cmx ubase/projectInfo.cmx uutil.cmi
+ fswatch.cmx fspath.cmx fpcache.cmx fingerprint.cmx fileinfo.cmx \
+ common.cmx case.cmx update.cmi
+uutil.cmo: ubase/util.cmi ubase/trace.cmi uutil.cmi
+uutil.cmx: ubase/util.cmx ubase/trace.cmx uutil.cmi
xferhint.cmo: ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi path.cmi os.cmi \
fspath.cmi xferhint.cmi
xferhint.cmx: ubase/util.cmx ubase/trace.cmx ubase/prefs.cmx path.cmx os.cmx \
fspath.cmx xferhint.cmi
+fsmonitor/watchercommon.cmo: lwt/lwt_unix.cmi lwt/lwt.cmi \
+ fsmonitor/watchercommon.cmi
+fsmonitor/watchercommon.cmx: lwt/lwt_unix.cmx lwt/lwt.cmx \
+ fsmonitor/watchercommon.cmi
lwt/lwt.cmo: lwt/lwt.cmi
lwt/lwt.cmx: lwt/lwt.cmi
lwt/lwt_unix.cmo: lwt/lwt_unix.cmi
@@ -324,8 +335,6 @@
ubase/prefs.cmi
ubase/prefs.cmx: ubase/util.cmx ubase/uarg.cmx system.cmx ubase/safelist.cmx \
ubase/prefs.cmi
-ubase/projectInfo.cmo:
-ubase/projectInfo.cmx:
ubase/proplist.cmo: ubase/util.cmi ubase/proplist.cmi
ubase/proplist.cmx: ubase/util.cmx ubase/proplist.cmi
ubase/rx.cmo: ubase/rx.cmi
@@ -344,6 +353,7 @@
ubase/util.cmi
ubase/util.cmx: ubase/uprintf.cmx system.cmx ubase/safelist.cmx \
ubase/util.cmi
+fsmonitor/watchercommon.cmi:
lwt/lwt.cmi:
lwt/lwt_unix.cmi: lwt/lwt.cmi
lwt/lwt_util.cmi: lwt/lwt.cmi
@@ -357,6 +367,22 @@
ubase/uarg.cmi:
ubase/uprintf.cmi:
ubase/util.cmi: system.cmi
+fsmonitor/linux/inotify.cmo: fsmonitor/linux/inotify.cmi
+fsmonitor/linux/inotify.cmx: fsmonitor/linux/inotify.cmi
+fsmonitor/linux/lwt_inotify.cmo: lwt/lwt_unix.cmi lwt/lwt.cmi \
+ fsmonitor/linux/inotify.cmi fsmonitor/linux/lwt_inotify.cmi
+fsmonitor/linux/lwt_inotify.cmx: lwt/lwt_unix.cmx lwt/lwt.cmx \
+ fsmonitor/linux/inotify.cmx fsmonitor/linux/lwt_inotify.cmi
+fsmonitor/linux/watcher.cmo: fsmonitor/watchercommon.cmi \
+ fsmonitor/linux/lwt_inotify.cmi lwt/lwt.cmi fsmonitor/linux/inotify.cmi
+fsmonitor/linux/watcher.cmx: fsmonitor/watchercommon.cmx \
+ fsmonitor/linux/lwt_inotify.cmx lwt/lwt.cmx fsmonitor/linux/inotify.cmx
+fsmonitor/windows/shortnames.cmo: fsmonitor/windows/shortnames.cmi
+fsmonitor/windows/shortnames.cmx: fsmonitor/windows/shortnames.cmi
+fsmonitor/windows/watcher.cmo: fsmonitor/watchercommon.cmi \
+ fsmonitor/windows/shortnames.cmi lwt/lwt.cmi
+fsmonitor/windows/watcher.cmx: fsmonitor/watchercommon.cmx \
+ fsmonitor/windows/shortnames.cmx lwt/lwt.cmx
lwt/example/editor.cmo: lwt/lwt_unix.cmi
lwt/example/editor.cmx: lwt/lwt_unix.cmx
lwt/example/relay.cmo: lwt/lwt_unix.cmi lwt/lwt.cmi
@@ -365,7 +391,13 @@
lwt/generic/lwt_unix_impl.cmx: lwt/pqueue.cmx lwt/lwt.cmx
lwt/win/lwt_unix_impl.cmo: lwt/pqueue.cmi lwt/lwt.cmi
lwt/win/lwt_unix_impl.cmx: lwt/pqueue.cmx lwt/lwt.cmx
+lwt/win/lwt_win.cmo: lwt/win/lwt_win.cmi
+lwt/win/lwt_win.cmx: lwt/win/lwt_win.cmi
system/generic/system_impl.cmo: system/system_generic.cmo
system/generic/system_impl.cmx: system/system_generic.cmx
system/win/system_impl.cmo: system/system_win.cmo system/system_generic.cmo
system/win/system_impl.cmx: system/system_win.cmx system/system_generic.cmx
+fsmonitor/linux/inotify.cmi:
+fsmonitor/linux/lwt_inotify.cmi: lwt/lwt.cmi fsmonitor/linux/inotify.cmi
+fsmonitor/windows/shortnames.cmi:
+lwt/win/lwt_win.cmi: lwt/lwt.cmi
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/Makefile.OCaml 2012-08-09 14:30:22 UTC (rev 506)
@@ -33,9 +33,12 @@
ifeq ($(shell uname),NetBSD)
OSARCH=NetBSD
endif
+ifeq ($(shell uname),Linux)
+ OSARCH=Linux
endif
endif
endif
+endif
ETAGS=etags
endif
endif
@@ -223,7 +226,7 @@
\
case.cmo pred.cmo uutil.cmo \
fileutil.cmo name.cmo path.cmo fspath.cmo fs.cmo fingerprint.cmo \
- abort.cmo osx.cmo external.cmo \
+ abort.cmo osx.cmo external.cmo fswatch.cmo \
props.cmo fileinfo.cmo os.cmo lock.cmo clroot.cmo common.cmo \
tree.cmo checksum.cmo terminal.cmo \
transfer.cmo xferhint.cmo remote.cmo globals.cmo fswatchold.cmo \
@@ -301,6 +304,19 @@
OCAMLLIBS+=lablgtk.cma
endif
+########################################################################
+### Filesystem monitoring
+
+ifeq ($(OSARCH),Linux)
+-include fsmonitor/linux/Makefile src/fsmonitor/linux/Makefile
+endif
+
+ifeq ($(OSARCH),win32gnuc)
+-include fsmonitor/windows/Makefile src/fsmonitor/windows/Makefile
+endif
+
+INCLFLAGS+=-I fsmonitor -I fsmonitor/linux -I fsmonitor/windows
+
####################################################################
### Static build setup
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/RECENTNEWS 2012-08-09 14:30:22 UTC (rev 506)
@@ -1,3 +1,10 @@
+CHANGES FROM VERSION 2.46.1
+
+* More robust file watching helper programs for Windows and Linux.
+ They communicate with Unison through pipes (Unison redirects stdin
+ and stdout), using a race-free protocol.
+
+-------------------------------
CHANGES FROM VERSION 2.46.0
* Added a "copyonconflict" preference, to make a copy of files that would
Modified: trunk/src/TODO.txt
===================================================================
--- trunk/src/TODO.txt 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/TODO.txt 2012-08-09 14:30:22 UTC (rev 506)
@@ -65,6 +65,19 @@
We're running under Cygwin (which is needed to have rsync)
+* The directory scanning optimization is currently disabled under Windows,
+ as FAT partitions do not have directory modification times.
+ we could check whether we are on an NTFS partition by calling
+ GetVolumeInformation to get the filesystem name.
+
+* We could defer most fingerprint computations to the propagation phase;
+ this would improve the user experience and save some fingerprints:
+ - do not compute fingerprint of new files during update detection
+ - during reconciliation, try to decide what to do based on what is
+ known so far
+ - for undecided paths (two files), request checksums (in batch)
+ - hashes are finally computed during propagation
+
###########################################################################
* SOON
Modified: trunk/src/fileinfo.ml
===================================================================
--- trunk/src/fileinfo.ml 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/fileinfo.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -55,13 +55,14 @@
if stats.Unix.LargeFile.st_kind = Unix.S_LNK
&& fromRoot
&& Path.followLink path
- then
+ then begin
+ Fswatch.followLink path;
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.toPrintString fullpath)))
- else
+ end else
stats
let get fromRoot fspath path =
Property changes on: trunk/src/fsmonitor
___________________________________________________________________
Added: svn:ignore
+ *.cm[ix]
Property changes on: trunk/src/fsmonitor/linux
___________________________________________________________________
Added: svn:ignore
+ *.cm[ix]
Added: trunk/src/fsmonitor/linux/Makefile
===================================================================
--- trunk/src/fsmonitor/linux/Makefile (rev 0)
+++ trunk/src/fsmonitor/linux/Makefile 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,21 @@
+
+FSMONITOR = $(NAME)-fsmonitor
+
+DIR=fsmonitor/linux
+FSMCAMLOBJS = \
+ lwt/lwt.cmx lwt/pqueue.cmx lwt/generic/lwt_unix_impl.cmx lwt/lwt_unix.cmx \
+ $(DIR)/inotify.cmx $(DIR)/lwt_inotify.cmx \
+ fsmonitor/watchercommon.cmx $(DIR)/watcher.cmx
+FSMCOBJS = \
+ $(DIR)/inotify_stubs.o
+FSMCAMLLIBS=unix.cmxa
+
+buildexecutable:: $(FSMONITOR)$(EXEC_EXT)
+
+$(FSMONITOR)$(EXEC_EXT): $(FSMCAMLOBJS) $(FSMCOBJS)
+ @echo Linking $@
+ $(OCAMLOPT) -verbose $(CAMLFLAGS) -o $@ $(CFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
+
+clean::
+ rm -f $(DIR)/*.cm[iox] $(DIR)/*.o $(DIR)/*~
+ rm -f $(FSMONITOR)$(EXEC_EXT)
\ No newline at end of file
Added: trunk/src/fsmonitor/linux/inotify.ml
===================================================================
--- trunk/src/fsmonitor/linux/inotify.ml (rev 0)
+++ trunk/src/fsmonitor/linux/inotify.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,119 @@
+(*
+ * Copyright (C) 2006-2008 Vincent Hanquez <vincent at snarc.org>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * 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 Lesser General Public License for more details.
+ *
+ * Inotify OCaml binding
+ *)
+
+exception Error of string * int
+
+type select_event =
+ | S_Access
+ | S_Attrib
+ | S_Close_write
+ | S_Close_nowrite
+ | S_Create
+ | S_Delete
+ | S_Delete_self
+ | S_Modify
+ | S_Move_self
+ | S_Moved_from
+ | S_Moved_to
+ | S_Open
+ | S_Dont_follow
+ | S_Mask_add
+ | S_Oneshot
+ | S_Onlydir
+ (* convenience *)
+ | S_Move
+ | S_Close
+ | S_All
+
+type type_event =
+ | Access
+ | Attrib
+ | Close_write
+ | Close_nowrite
+ | Create
+ | Delete
+ | Delete_self
+ | Modify
+ | Move_self
+ | Moved_from
+ | Moved_to
+ | Open
+ | Ignored
+ | Isdir
+ | Q_overflow
+ | Unmount
+
+let string_of_event = function
+ | Access -> "ACCESS"
+ | Attrib -> "ATTRIB"
+ | Close_write -> "CLOSE_WRITE"
+ | Close_nowrite -> "CLOSE_NOWRITE"
+ | Create -> "CREATE"
+ | Delete -> "DELETE"
+ | Delete_self -> "DELETE_SELF"
+ | Modify -> "MODIFY"
+ | Move_self -> "MOVE_SELF"
+ | Moved_from -> "MOVED_FROM"
+ | Moved_to -> "MOVED_TO"
+ | Open -> "OPEN"
+ | Ignored -> "IGNORED"
+ | Isdir -> "ISDIR"
+ | Q_overflow -> "Q_OVERFLOW"
+ | Unmount -> "UNMOUNT"
+
+let int_of_wd wd = wd
+
+type wd = int
+type event = wd * type_event list * int32 * string option
+
+external init : unit -> Unix.file_descr = "stub_inotify_init"
+external add_watch : Unix.file_descr -> string -> select_event list -> wd
+ = "stub_inotify_add_watch"
+external rm_watch : Unix.file_descr -> wd -> unit = "stub_inotify_rm_watch"
+external convert : string -> (wd * type_event list * int32 * int)
+ = "stub_inotify_convert"
+external struct_size : unit -> int = "stub_inotify_struct_size"
+
+external to_read : Unix.file_descr -> int = "stub_inotify_ioctl_fionread"
+
+let read fd =
+ let ss = struct_size () in
+ let toread = to_read fd in
+
+ let ret = ref [] in
+ let buf = String.make toread '\000' in
+ let toread = Unix.read fd buf 0 toread in
+
+ let read_c_string offset len =
+ let index = ref 0 in
+ while !index < len && buf.[offset + !index] <> '\000' do incr index done;
+ String.sub buf offset !index
+ in
+
+ let i = ref 0 in
+
+ while !i < toread
+ do
+ let wd, l, cookie, len = convert (String.sub buf !i ss) in
+ let s = if len > 0 then Some (read_c_string (!i + ss) len) else None in
+ ret := (wd, l, cookie, s) :: !ret;
+ i := !i + (ss + len);
+ done;
+
+ List.rev !ret
+
+let _ = Callback.register_exception "inotify.error" (Error ("register_callback", 0))
+
Added: trunk/src/fsmonitor/linux/inotify.mli
===================================================================
--- trunk/src/fsmonitor/linux/inotify.mli (rev 0)
+++ trunk/src/fsmonitor/linux/inotify.mli 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,66 @@
+(*
+ * Copyright (C) 2006-2008 Vincent Hanquez <vincent at snarc.org>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * 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 Lesser General Public License for more details.
+ *
+ * Inotify OCaml binding
+ *)
+exception Error of string * int
+
+type select_event =
+| S_Access
+| S_Attrib
+| S_Close_write
+| S_Close_nowrite
+| S_Create
+| S_Delete
+| S_Delete_self
+| S_Modify
+| S_Move_self
+| S_Moved_from
+| S_Moved_to
+| S_Open
+| S_Dont_follow
+| S_Mask_add
+| S_Oneshot
+| S_Onlydir
+| S_Move
+| S_Close
+| S_All
+
+type type_event =
+| Access
+| Attrib
+| Close_write
+| Close_nowrite
+| Create
+| Delete
+| Delete_self
+| Modify
+| Move_self
+| Moved_from
+| Moved_to
+| Open
+| Ignored
+| Isdir
+| Q_overflow
+| Unmount
+
+type wd
+type event = wd * type_event list * int32 * string option
+
+val int_of_wd : wd -> int
+val string_of_event : type_event -> string
+
+val init : unit -> Unix.file_descr
+val add_watch : Unix.file_descr -> string -> select_event list -> wd
+val rm_watch : Unix.file_descr -> wd -> unit
+val read : Unix.file_descr -> event list
Added: trunk/src/fsmonitor/linux/inotify_stubs.c
===================================================================
--- trunk/src/fsmonitor/linux/inotify_stubs.c (rev 0)
+++ trunk/src/fsmonitor/linux/inotify_stubs.c 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,150 @@
+/*
+ * Copyright (C) 2006-2008 Vincent Hanquez <vincent at snarc.org>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * 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 Lesser General Public License for more details.
+ *
+ * Inotify Ocaml binding - C glue
+ */
+
+#include <errno.h>
+#include <string.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <sys/ioctl.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+#include <caml/callback.h>
+
+#include <features.h>
+
+#if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 4
+#define GLIBC_SUPPORT_INOTIFY 1
+#else
+#define GLIBC_SUPPORT_INOTIFY 0
+#endif
+
+#if GLIBC_SUPPORT_INOTIFY
+#include <sys/inotify.h>
+#else
+#include "inotify_compat.h"
+#endif
+
+static int inotify_flag_table[] = {
+ IN_ACCESS, IN_ATTRIB, IN_CLOSE_WRITE, IN_CLOSE_NOWRITE,
+ IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MODIFY,
+ IN_MOVE_SELF, IN_MOVED_FROM, IN_MOVED_TO, IN_OPEN,
+ IN_DONT_FOLLOW, IN_MASK_ADD, IN_ONESHOT, IN_ONLYDIR,
+ IN_MOVE, IN_CLOSE, IN_ALL_EVENTS, 0
+};
+
+static int inotify_return_table[] = {
+ IN_ACCESS, IN_ATTRIB, IN_CLOSE_WRITE, IN_CLOSE_NOWRITE,
+ IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MODIFY,
+ IN_MOVE_SELF, IN_MOVED_FROM, IN_MOVED_TO, IN_OPEN,
+ IN_IGNORED, IN_ISDIR, IN_Q_OVERFLOW, IN_UNMOUNT, 0
+};
+
+static void raise_inotify_error(char const *msg)
+{
+ static value *inotify_err = NULL;
+ value args[2];
+
+ if (!inotify_err)
+ inotify_err = caml_named_value("inotify.error");
+ args[0] = caml_copy_string(msg);
+ args[1] = Val_int(errno);
+
+ caml_raise_with_args(*inotify_err, 2, args);
+}
+
+value stub_inotify_init(value unit)
+{
+ CAMLparam1(unit);
+ int fd;
+
+ fd = inotify_init();
+ CAMLreturn(Val_int(fd));
+}
+
+value stub_inotify_ioctl_fionread(value fd)
+{
+ CAMLparam1(fd);
+ int rc, bytes;
+
+ rc = ioctl(Int_val(fd), FIONREAD, &bytes);
+ if (rc == -1)
+ raise_inotify_error("ioctl fionread");
+
+ CAMLreturn(Val_int(bytes));
+}
+
+value stub_inotify_add_watch(value fd, value path, value mask)
+{
+ CAMLparam3(fd, path, mask);
+ int cv_mask, wd;
+
+ cv_mask = caml_convert_flag_list(mask, inotify_flag_table);
+ wd = inotify_add_watch(Int_val(fd), String_val(path), cv_mask);
+ if (wd < 0)
+ raise_inotify_error("add_watch");
+ CAMLreturn(Val_int(wd));
+}
+
+value stub_inotify_rm_watch(value fd, value wd)
+{
+ CAMLparam2(fd, wd);
+ int ret;
+
+ ret = inotify_rm_watch(Int_val(fd), Int_val(wd));
+ if (ret == -1)
+ raise_inotify_error("rm_watch");
+ CAMLreturn(Val_unit);
+}
+
+value stub_inotify_struct_size(void)
+{
+ CAMLparam0();
+ CAMLreturn(Val_int(sizeof(struct inotify_event)));
+}
+
+value stub_inotify_convert(value buf)
+{
+ CAMLparam1(buf);
+ CAMLlocal3(event, l, tmpl);
+ struct inotify_event ev;
+ int i;
+
+ l = Val_emptylist;
+ tmpl = Val_emptylist;
+
+ memcpy(&ev, String_val(buf), sizeof(struct inotify_event));
+
+ for (i = 0; inotify_return_table[i]; i++) {
+ if (!(ev.mask & inotify_return_table[i]))
+ continue;
+ tmpl = caml_alloc_small(2, Tag_cons);
+ Field(tmpl, 0) = Val_int(i);
+ Field(tmpl, 1) = l;
+ l = tmpl;
+ }
+
+ event = caml_alloc_tuple(4);
+ Store_field(event, 0, Val_int(ev.wd));
+ Store_field(event, 1, l);
+ Store_field(event, 2, caml_copy_int32(ev.cookie));
+ Store_field(event, 3, Val_int(ev.len));
+
+ CAMLreturn(event);
+}
Added: trunk/src/fsmonitor/linux/lwt_inotify.ml
===================================================================
--- trunk/src/fsmonitor/linux/lwt_inotify.ml (rev 0)
+++ trunk/src/fsmonitor/linux/lwt_inotify.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,49 @@
+(* Unison file synchronizer: src/monitoring-linux/lwt_inotify.ml *)
+(* Copyright 1999-2012, 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/>.
+*)
+
+let (>>=) = Lwt.bind
+
+type t =
+ { fd : Unix.file_descr;
+ lwt_fd : Lwt_unix.file_descr;
+ q : Inotify.event Queue.t }
+
+let init () =
+ let fd = Inotify.init () in
+ { fd = fd;
+ lwt_fd =
+ Lwt_unix.of_unix_file_descr (*~blocking:false ~set_flags:true*) fd;
+ q = Queue.create () }
+
+let add_watch st path sel =
+(* Lwt_unix.check_descriptor st.lwt_fd;*)
+ Inotify.add_watch st.fd path sel
+
+let rm_watch st wd =
+(* Lwt_unix.check_descriptor st.lwt_fd;*)
+ Inotify.rm_watch st.fd wd
+
+let rec read st =
+ try
+ Lwt.return (Queue.take st.q)
+ with Queue.Empty ->
+ Lwt_unix.wait_read st.lwt_fd >>= fun () ->
+ let l = Inotify.read st.fd in
+ List.iter (fun ev -> Queue.push ev st.q) l;
+ read st
+
+let close st = Lwt_unix.close st.lwt_fd
Added: trunk/src/fsmonitor/linux/lwt_inotify.mli
===================================================================
--- trunk/src/fsmonitor/linux/lwt_inotify.mli (rev 0)
+++ trunk/src/fsmonitor/linux/lwt_inotify.mli 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,10 @@
+(* Unison file synchronizer: src/monitoring-linux/lwt_inotify.mli *)
+(* Copyright 2012, Benjamin C. Pierce (see COPYING for details) *)
+
+type t
+
+val init : unit -> t
+val add_watch : t -> string -> Inotify.select_event list -> Inotify.wd
+val rm_watch : t -> Inotify.wd -> unit
+val read : t -> Inotify.event Lwt.t
+val close : t -> unit (*Lwt.t*)
Added: trunk/src/fsmonitor/linux/watcher.ml
===================================================================
--- trunk/src/fsmonitor/linux/watcher.ml (rev 0)
+++ trunk/src/fsmonitor/linux/watcher.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,247 @@
+(* Unison file synchronizer: src/fsmonitoring/linux/watcher.ml *)
+(* Copyright 2012, 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/>.
+*)
+
+(*
+LIMITATIONS
+- we do not detect when a directory below a path is moved;
+- same limitation for the directories containing symlinked files;
+- do not watch chains of symlinks (only the first symlink and the
+ final target are watched)
+- we do not watch non-existent roots
+
+POSSIBLE IMPROVEMENTS
+- there could be a special case for directory attribute changes
+
+Maybe we should ignore Unison temporary files
+*)
+
+let (>>=) = Lwt.bind
+
+module M = Watchercommon.F(struct type watch = Inotify.wd end)
+include M
+
+(****)
+
+module Linux = struct
+
+let print_opt_path f p =
+ match p with
+ Some p -> Format.fprintf f " \"%s\"" p
+ | None -> ()
+
+let print_event path_of_id (wd, evl, id, p) =
+ Format.eprintf "%02d %s%a"
+ (Inotify.int_of_wd wd) (path_of_id wd) print_opt_path p;
+ List.iter (fun ev -> Format.eprintf " %s" (Inotify.string_of_event ev)) evl;
+ if id <> 0l then Format.eprintf " %08lx" id;
+ Format.eprintf "@."
+
+let action_kind ev =
+ Inotify.
+ (match ev with
+ | Access -> `OTHER
+ | Attrib -> `MODIF
+ | Close_write -> `OTHER
+ | Close_nowrite -> `OTHER
+ | Create -> `CREAT
+ | Delete -> `DEL
+ | Delete_self -> `DEL
+ | Modify -> `MODIF
+ | Move_self -> `DEL
+ | Moved_from -> `DEL
+ | Moved_to -> `MODIF
+ | Open -> `OTHER
+ | Ignored -> `OTHER
+ | Isdir -> `OTHER
+ | Q_overflow -> `OTHER
+ | Unmount -> `DEL)
+
+let event_kind (_, evl, _, _) =
+ List.fold_left (fun k act -> if k = `OTHER then action_kind act else k)
+ `OTHER evl
+
+let is_change ev =
+ Inotify.
+ (match ev with
+ | Access -> false
+ | Attrib -> true
+ | Close_write -> false
+ | Close_nowrite -> false
+ | Create -> true
+ | Delete -> true
+ | Delete_self -> true
+ | Modify -> true
+ | Move_self -> true
+ | Moved_from -> true
+ | Moved_to -> true
+ | Open -> false
+ | Ignored -> false
+ | Isdir -> false
+ | Q_overflow -> false
+ | Unmount -> true)
+
+let is_creation ev = ev = Inotify.Create
+
+let is_deletion ev =
+ Inotify.
+ (match ev with
+ | Access -> false
+ | Attrib -> false
+ | Close_write -> false
+ | Close_nowrite -> false
+ | Create -> false
+ | Delete -> true
+ | Delete_self -> true
+ | Modify -> false
+ | Move_self -> true
+ | Moved_from -> true
+ | Moved_to -> false
+ | Open -> false
+ | Ignored -> false
+ | Isdir -> false
+ | Q_overflow -> false
+ | Unmount -> true)
+
+let is_immediate ev =
+ Inotify.
+ (match ev with
+ | Access -> false
+ | Attrib -> false
+ | Close_write -> false
+ | Close_nowrite -> false
+ | Create -> false
+ | Delete -> true
+ | Delete_self -> true
+ | Modify -> false
+ | Move_self -> true
+ | Moved_from -> true
+ | Moved_to -> true
+ | Open -> false
+ | Ignored -> false
+ | Isdir -> false
+ | Q_overflow -> false
+ | Unmount -> true)
+
+let event_is_change (_, evl, _, _) = List.exists is_change evl
+let event_is_creation (_, evl, _, _) = List.exists is_creation evl
+let event_is_deletion (_, evl, _, _) = List.exists is_deletion evl
+let event_is_immediate (_, evl, _, _) = List.exists is_immediate evl
+
+let st = Lwt_inotify.init ()
+
+module IntSet =
+ Set.Make
+ (struct type t = int let compare (x : int) (y : int) = compare x y end)
+
+let watcher_by_id = Hashtbl.create 16
+
+let path_of_id id =
+ try
+ dir_path
+ (Hashtbl.find file_by_id (IntSet.choose (Hashtbl.find watcher_by_id id)))
+ ""
+ with Not_found ->
+ Format.sprintf "????"
+
+let previous_event = ref None
+let time_ref = ref (ref 0.)
+
+let clear_event_memory () = previous_event := None
+
+let rec watch_rec () =
+ Lwt_inotify.read st >>= fun ((wd, evl, _, nm_opt) as ev) ->
+ let time = Unix.gettimeofday () in
+ if !previous_event <> Some ev then begin
+ previous_event := Some ev;
+ if !Watchercommon.debug then print_event path_of_id ev;
+ time_ref := ref time;
+ let kind = event_kind ev in
+ if kind <> `OTHER then begin
+ try
+ let files = Hashtbl.find watcher_by_id wd in
+ let event_time = if event_is_immediate ev then ref 0. else !time_ref in
+ IntSet.iter
+ (fun file ->
+ signal_change
+ event_time (Hashtbl.find file_by_id file) nm_opt kind)
+ files
+ with Not_found ->
+ ()
+ end else if List.mem Inotify.Q_overflow evl then begin
+ if !Watchercommon.debug then Format.eprintf "OVERFLOW at .";
+ signal_overflow ()
+ end
+ end else
+ !time_ref := time;
+ watch_rec ()
+
+let watch () =
+ ignore
+ (Lwt.catch (fun () -> watch_rec ())
+ (fun e ->
+ Watchercommon.error
+ ("error while handling events: " ^ Watchercommon.format_exc e)))
+
+let release_watch file =
+ match get_watch file with
+ None ->
+ ()
+ | Some id ->
+ set_watch file None;
+ let s = IntSet.remove (get_id file) (Hashtbl.find watcher_by_id id) in
+ if IntSet.is_empty s then begin
+ begin try
+ Lwt_inotify.rm_watch st id
+ (* Will fail with EINVAL if the file has been deleted... *)
+ with Inotify.Error (_, no) ->
+ ()
+ end;
+ Hashtbl.remove watcher_by_id id
+ end else
+ Hashtbl.replace watcher_by_id id s
+
+let selected_events =
+ Inotify.([S_Attrib; S_Modify; S_Delete_self; S_Move_self;
+ S_Create; S_Delete; S_Modify; S_Moved_from; S_Moved_to])
+
+let add_watch path file =
+ try
+ let id = Lwt_inotify.add_watch st path selected_events in
+ begin match get_watch file with
+ Some id' when id = id' ->
+ ()
+ | _ ->
+ release_watch file;
+ let s =
+ try Hashtbl.find watcher_by_id id with Not_found -> IntSet.empty in
+ Hashtbl.replace watcher_by_id id (IntSet.add (get_id file) s);
+ set_watch file (Some id)
+ end
+ with Inotify.Error (_, no) ->
+ release_watch file;
+ match no with
+ 2 | 13 | 20 | 28 | 40 ->
+ ()
+ | _ ->
+ Watchercommon.error
+ (Format.sprintf "unexpected error %d while adding a watcher" no)
+
+end
+
+(****)
+
+include F(Linux)
Added: trunk/src/fsmonitor/watchercommon.ml
===================================================================
--- trunk/src/fsmonitor/watchercommon.ml (rev 0)
+++ trunk/src/fsmonitor/watchercommon.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,615 @@
+(* Unison file synchronizer: src/fsmonitoring/watchercommon.ml *)
+(* Copyright 2012, 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/>.
+*)
+
+let debug = ref false
+
+let _ =
+ if Sys.os_type = "Unix" then
+ ignore(Sys.set_signal Sys.sigpipe Sys.Signal_ignore)
+
+module StringMap = Map.Make(String)
+module StringSet = Set.Make(String)
+module IntSet =
+ Set.Make
+ (struct type t = int let compare (x : int) (y : int) = compare x y end)
+
+let disallowed_char c =
+ match c with
+ 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '_' | '.' | '~'
+ | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&'
+ | '=' | '+' | '$' | ',' | '/' | '?' | '#' | '[' | ']' ->
+ false
+ | _ ->
+ true
+
+let quote s =
+ let l = String.length s in
+ let n = ref 0 in
+ for i = 0 to l - 1 do if disallowed_char s.[i] then incr n done;
+ if !n = 0 then s else begin
+ let q = String.create (l + 2 * !n) in
+ let j = ref 0 in
+ let hex = "0123456789ABCDEF" in
+ for i = 0 to l - 1 do
+ let c = s.[i] in
+ if disallowed_char s.[i] then begin
+ q.[!j] <- '%';
+ q.[!j + 1] <- hex.[Char.code c lsr 4];
+ q.[!j + 2] <- hex.[Char.code c land 15];
+ j := !j + 3
+ end else begin
+ q.[!j] <- c;
+ incr j
+ end
+ done;
+ q
+ end
+
+let unquote s =
+ let l = String.length s in
+ let n = ref 0 in
+ for i = 0 to l - 1 do if s.[i] = '%' then incr n done;
+ if !n = 0 then s else begin
+ let hex_char c =
+ match c with
+ '0'..'9' -> Char.code c - Char.code '0'
+ | 'a'..'f' -> Char.code c - Char.code 'a' + 10
+ | 'A'..'F' -> Char.code c - Char.code 'A' + 10
+ | _ -> invalid_arg "unquote"
+ in
+ let u = String.create (l - 2 * !n) in
+ let j = ref 0 in
+ for i = 0 to l - 2 * !n - 1 do
+ let c = s.[!j] in
+ if c = '%' then begin
+ u.[i] <- Char.chr ((hex_char s.[!j + 1]) lsl 4 + hex_char s.[!j + 2]);
+ j := !j + 3
+ end else begin
+ u.[i] <- c;
+ incr j
+ end
+ done;
+ u
+ end
+
+let split_on_space s =
+ try
+ let i = String.index s ' ' in
+ (String.sub s 0 i,
+ String.sub s (i + 1) (String.length s - i - 1))
+ with Not_found ->
+ (s, "")
+
+let (>>=) = Lwt.bind
+
+let rec really_write o s pos len =
+ Lwt_unix.write o s pos len >>= fun l ->
+ if l = len then
+ Lwt.return ()
+ else
+ really_write o s (pos + l) (len - l)
+
+let format_exc e =
+ match e with
+ Unix.Unix_error (code, funct, arg) ->
+ Format.sprintf "%s [%s%s]%s at ."
+ (Unix.error_message code) funct
+ (if String.length arg > 0 then "(" ^ arg ^ ")" else "")
+ (match code with
+ Unix.EUNKNOWNERR n -> Format.sprintf " (code %d)" n
+ | _ -> "")
+ | _ ->
+ Format.sprintf "uncaugth exception %s at ." (Printexc.to_string e)
+
+(****)
+
+let _in = (*Lwt_unix.stdin*) Lwt_unix.of_unix_file_descr Unix.stdin
+let _out = (*Lwt_unix.stdout*) Lwt_unix.of_unix_file_descr Unix.stdout
+
+let printf fmt =
+ Printf.ksprintf (fun s -> really_write _out s 0 (String.length s)) fmt
+
+let read_line =
+ let b = Buffer.create 160 in
+ let buf = String.create 160 in
+ let start = ref 0 in
+ let last = ref 0 in
+ let rec read_line () =
+ begin if !start = !last then begin
+ Lwt_unix.read _in buf 0 160 >>= fun l ->
+ if l = 0 then raise End_of_file;
+ start := 0; last := l;
+ Lwt.return ()
+ end else
+ Lwt.return ()
+ end >>= fun () ->
+ try
+ let i = String.index_from buf !start '\n' in
+ if i >= !last then raise Not_found;
+ Buffer.add_substring b buf !start (i - !start);
+ start := i + 1;
+ let s = Buffer.contents b in
+ Buffer.clear b;
+ Lwt.return s
+ with Not_found ->
+ Buffer.add_substring b buf !start (!last - !start);
+ start := 0; last := 0;
+ read_line ()
+ in
+ read_line
+
+let error msg =
+ Lwt_unix.run (printf "ERROR %s\n" (quote msg));
+ exit 1
+
+(****)
+
+module F (M : sig type watch end) = struct
+include M
+
+type status = Modified | Created
+
+type t =
+ { id : int; mutable gen : int;
+ mutable watch : watch option;
+ mutable subdirs : t StringMap.t;
+ parent : parent;
+ archive_hash : string;
+ mutable changed : bool;
+ mutable changed_children : (status * float ref) StringMap.t }
+
+and parent = Root of string * string | Parent of string * t
+
+let get_id file = file.id
+let get_watch file = file.watch
+let set_watch file watch = file.watch <- watch
+let get_subdirs file = file.subdirs
+
+let current_gen = ref 0
+
+let file_by_id = Hashtbl.create 16
+let roots = Hashtbl.create 16
+
+let concat fspath path =
+ if path = "" then fspath else Filename.concat fspath path
+
+let is_root file =
+ match file.parent with
+ Root _ -> true
+ | Parent _ -> false
+
+let rec dir_path dir path =
+ match dir.parent with
+ Root (fspath, path') -> concat fspath (concat path' path)
+ | Parent (name, dir) -> dir_path dir (concat name path)
+
+(****)
+
+let delay = 0.5
+
+let changes = ref StringMap.empty
+
+let waiting_for_changes = ref StringSet.empty
+let active_wait = ref false
+
+let change_table hash =
+ try
+ StringMap.find hash !changes
+ with Not_found ->
+ let h = Hashtbl.create 1024 in
+ changes := StringMap.add hash h !changes;
+ h
+
+let signal_changes replicas_with_changes =
+ waiting_for_changes := StringSet.empty;
+ printf "CHANGES %s\n"
+ (String.concat " "
+ (List.map quote (StringSet.elements replicas_with_changes)))
+
+let signal_immediate_changes hash =
+ if StringSet.mem hash !waiting_for_changes then begin
+ waiting_for_changes := StringSet.empty;
+ printf "CHANGES %s\n" (quote hash)
+ end else
+ Lwt.return ()
+
+let replicas_with_changes watched_replicas =
+ let time = Unix.gettimeofday () in
+ let changed = ref StringSet.empty in
+ Hashtbl.iter
+ (fun (hash', _, _) r ->
+ if
+ r.changed &&
+ not (StringSet.mem hash' !changed) &&
+ StringSet.mem hash' watched_replicas
+ then
+ changed := StringSet.add hash' !changed)
+ roots;
+ StringSet.iter
+ (fun hash ->
+ if not (StringSet.mem hash !changed) then
+ try
+ Hashtbl.iter
+ (fun _ time_ref -> if time -. !time_ref > delay then raise Exit)
+ (change_table hash)
+ with Exit ->
+ changed := StringSet.add hash !changed)
+ watched_replicas;
+ !changed
+
+let has_impending_changes watched_replicas =
+ try
+ StringSet.iter
+ (fun hash -> Hashtbl.iter (fun _ _ -> raise Exit) (change_table hash))
+ watched_replicas;
+ false
+ with Exit ->
+ true
+
+let rec wait_for_changes watched_replicas =
+ if not (StringSet.is_empty watched_replicas) then begin
+ let changed = replicas_with_changes watched_replicas in
+ if not (StringSet.is_empty changed) then signal_changes changed else
+ if has_impending_changes watched_replicas then signal_impending_changes ()
+ else Lwt.return ()
+ end else
+ Lwt.return ()
+
+and signal_impending_changes () =
+ if not (StringSet.is_empty !waiting_for_changes || !active_wait) then begin
+ active_wait := true;
+ Lwt_unix.sleep delay >>= fun () ->
+ active_wait := false;
+ wait_for_changes !waiting_for_changes
+ end else
+ Lwt.return ()
+
+let wait hash =
+ waiting_for_changes := StringSet.add hash !waiting_for_changes;
+ ignore (wait_for_changes (StringSet.singleton hash))
+
+let add_change dir nm time =
+ Hashtbl.replace (change_table dir.archive_hash) (dir.id, nm) time;
+ if !time = 0. then
+ ignore (signal_immediate_changes dir.archive_hash)
+ else
+ ignore (signal_impending_changes ())
+let remove_change dir nm =
+ Hashtbl.remove (change_table dir.archive_hash) (dir.id, nm)
+let clear_change_table hash =
+ changes := StringMap.remove hash !changes
+
+let rec clear_changes hash time =
+ let rec clear_rec f =
+ f.changed_children <-
+ StringMap.filter
+ (fun nm (_, time_ref) ->
+ if time -. !time_ref <= delay then true else begin
+ remove_change f nm;
+ false
+ end)
+ f.changed_children;
+ StringMap.iter (fun _ f' -> clear_rec f') f.subdirs
+ in
+ Hashtbl.iter
+ (fun (hash', _, _) f ->
+ if hash' = hash then begin
+ f.changed <- false;
+ clear_rec f
+ end)
+ roots
+
+(****)
+
+let rec signal_change time dir nm_opt kind =
+ match nm_opt with
+ Some nm ->
+ begin try
+ let (st, _) = StringMap.find nm dir.changed_children in
+ if
+ st = Created && kind = `DEL &&
+ not (StringMap.mem nm dir.subdirs)
+ then begin
+ if !debug then Format.eprintf "Deleted: %s at ." (dir_path dir nm);
+ dir.changed_children <- StringMap.remove nm dir.changed_children;
+ remove_change dir nm
+ end else begin
+ dir.changed_children <-
+ StringMap.add nm (st, time) dir.changed_children;
+ add_change dir nm time
+ end
+ with Not_found ->
+ if kind = `CREAT && dir.gen <> !current_gen then begin
+ if !debug then Format.eprintf "Created: %s at ." (dir_path dir nm);
+ dir.changed_children <-
+ StringMap.add nm (Created, time) dir.changed_children;
+ add_change dir nm time
+ end else begin
+ if !debug then Format.eprintf "Modified: %s at ." (dir_path dir nm);
+ dir.changed_children <-
+ StringMap.add nm (Modified, time) dir.changed_children;
+ add_change dir nm time
+ end
+ end
+ | None ->
+ match dir.parent with
+ Root _ ->
+ dir.changed <- true;
+ ignore (signal_immediate_changes dir.archive_hash)
+ | Parent (nm, parent_dir) ->
+ signal_change time parent_dir (Some nm) kind
+
+let signal_overflow () =
+ Hashtbl.iter (fun _ r -> r.changed <- true) roots;
+ ignore (signal_changes !waiting_for_changes)
+
+(****)
+
+module type S = sig
+ val add_watch : string -> t -> unit
+ val release_watch : t -> unit
+ val watch : unit -> unit
+ val clear_event_memory : unit -> unit
+end
+
+module F (M : S) = struct
+include M
+
+let gather_changes hash time =
+ clear_event_memory ();
+ let rec gather_rec path r l =
+ let c =
+ StringMap.filter (fun _ (_, time_ref) -> time -. !time_ref > delay)
+ r.changed_children
+ in
+ let l = StringMap.fold (fun nm _ l -> concat path nm :: l) c l in
+ StringMap.fold
+ (fun nm r' l ->
+ if StringMap.mem nm c then l else
+ gather_rec (concat path nm) r' l)
+ r.subdirs l
+ in
+ List.rev
+ (Hashtbl.fold
+ (fun (hash', _, path) r l ->
+ if hash' <> hash then l else
+ (* If this path is not watched (presumably, it does not exist),
+ we report that it should be scanned again. On the other hand,
+ this is not reported as a change by the WAIT function, so that
+ Unison does not loop checking this path. *)
+ if r.changed && r.watch = None then path :: l else
+ gather_rec path r l)
+ roots [])
+
+let rec find_root hash fspath path =
+ if Hashtbl.mem roots (hash, fspath, path) then
+ Some (fspath, path)
+ else
+ try
+ let i = String.rindex path '/' in
+ find_root hash fspath (String.sub path 0 i)
+ with Not_found ->
+ if path = "" then
+ None
+ else
+ find_root hash fspath ""
+
+let last_file_id = ref 0
+
+let new_file hash parent =
+ let f =
+ { id = !last_file_id; watch = None; gen = -1;
+ parent = parent; archive_hash = hash; subdirs = StringMap.empty;
+ changed = false; changed_children = StringMap.empty }
+ in
+ incr last_file_id;
+ Hashtbl.add file_by_id f.id f;
+ f
+
+let new_root hash fspath path =
+ if !debug then Format.eprintf "ROOT %s %s at ." fspath path;
+ let r = new_file hash (Root (fspath, path)) in
+ Hashtbl.add roots (hash, fspath, path) r;
+ r
+
+let dir_child dir name =
+ try
+ StringMap.find name dir.subdirs
+ with Not_found ->
+ let d = new_file dir.archive_hash (Parent (name, dir)) in
+ dir.subdirs <- StringMap.add name d dir.subdirs;
+ d
+
+let rec follow_path dir path pos =
+ if path = "" then dir else
+ try
+ let i = String.index_from path pos '/' in
+ try
+ let dir = StringMap.find (String.sub path pos (i - pos)) dir.subdirs in
+ follow_path dir path (i + 1)
+ with Not_found ->
+ assert false
+ with Not_found ->
+ dir_child dir (String.sub path pos (String.length path - pos))
+
+let rec follow_fspath hash fspath dir path pos =
+ if path = "" then dir else
+ try
+ let i = String.index_from path pos '/' in
+ try
+ let dir = StringMap.find (String.sub path pos (i - pos)) dir.subdirs in
+ follow_fspath hash fspath dir path (i + 1)
+ with Not_found ->
+ new_root hash fspath path
+ with Not_found ->
+ dir_child dir (String.sub path pos (String.length path - pos))
+
+let find_start hash fspath path =
+ match find_root hash fspath path with
+ None ->
+ new_root hash fspath path
+ | Some (root_fspath, root_path) ->
+ let root = Hashtbl.find roots (hash, root_fspath, root_path) in
+ if fspath = root_fspath && path = root_path then
+ root
+ else
+ follow_fspath hash fspath root path
+ (if root_path = "" then 0 else String.length root_path + 1)
+
+let clear_file_changes file =
+ StringMap.iter (fun nm _ -> remove_change file nm) file.changed_children;
+ file.changed_children <- StringMap.empty;
+ file.changed <- false
+
+let rec remove_file file =
+ if !debug then Format.eprintf "REMOVING %s at ." (dir_path file "");
+ StringMap.iter (fun _ f -> remove_file f) file.subdirs;
+ Hashtbl.remove file_by_id file.id;
+ release_watch file;
+ match file.parent with
+ Root _ -> ()
+ | Parent (nm, p) -> p.subdirs <- StringMap.remove nm p.subdirs
+
+let rec remove_old_files file =
+ if file.gen <> !current_gen then remove_file file else begin
+ StringMap.iter (fun _ f -> remove_old_files f) file.subdirs;
+ if
+ file.watch = None && StringMap.is_empty file.subdirs &&
+ not (is_root file)
+ then
+ remove_file file
+ end
+
+let print_ack () = printf "OK\n"
+
+let start_watching hash fspath path =
+ let start_file = find_start hash fspath path in
+ clear_file_changes start_file;
+ start_file.gen <- !current_gen;
+ let fspath = concat fspath path in
+(*Format.eprintf ">>> %s at ." fspath;*)
+ if is_root start_file then add_watch fspath start_file;
+ print_ack () >>= fun () ->
+ let rec add_directories () =
+ read_line () >>= fun l ->
+ let (cmd, path) = split_on_space l in
+ let path = unquote path in
+ match cmd with
+ "DIR" ->
+(*Format.eprintf "DIR %s at ." path;*)
+ let fullpath = concat fspath path in
+ let file = follow_path start_file path 0 in
+ clear_file_changes file;
+ file.gen <- !current_gen;
+(*Format.eprintf "%s at ." fullpath;*)
+ add_watch fullpath file;
+ print_ack () >>= fun () ->
+ add_directories ()
+ | "LINK" ->
+(*Format.eprintf "LINK %s at ." path;*)
+ let fullpath = concat fspath path in
+ let file = follow_path start_file path 0 in
+ clear_file_changes file;
+ file.gen <- !current_gen;
+(*Format.eprintf "%s at ." fullpath;*)
+ add_watch fullpath file;
+ print_ack () >>= fun () ->
+ add_directories ()
+ | "DONE" ->
+ Lwt.return ()
+ | _ ->
+ error (Format.sprintf "unknown command '%s'" cmd)
+ in
+ add_directories () >>= fun () ->
+ (* We remove any file which is not watched anymore,
+ as well as files which are not in fact watched. *)
+ remove_old_files start_file;
+ incr current_gen;
+ Lwt.return ()
+
+(****)
+
+let reset hash =
+ let l = ref [] in
+ Hashtbl.iter
+ (fun ((hash', _, _) as key) f ->
+ if hash' = hash then begin
+ l := key :: !l;
+ remove_file f
+ end)
+ roots;
+ List.iter (fun key -> Hashtbl.remove roots key) !l;
+ clear_change_table hash
+
+(****)
+
+let rec lazy_fold_right f l accu =
+ match l with
+ [] -> accu ()
+ | a::l -> f a (fun () -> lazy_fold_right f l accu)
+
+let output_changes hash =
+ let time = Unix.gettimeofday () in
+ let lst = gather_changes hash time in
+ clear_changes hash time;
+ lazy_fold_right (fun p cont -> printf "RECURSIVE %s\n" (quote p) >>= cont)
+ lst (fun () -> printf "DONE\n")
+
+let rec loop () =
+ read_line () >>= fun l ->
+ (* Cancel any wait when receiving a command *)
+ let (cmd, args) = split_on_space l in
+ if cmd <> "WAIT" then waiting_for_changes := StringSet.empty;
+ match cmd with
+ "VERSION" ->
+ loop ()
+ | "DEBUG" ->
+ debug := true;
+ loop ()
+ | "START" ->
+ let (hash, rem) = split_on_space args in
+ let (fspath, path) = split_on_space rem in
+ start_watching (unquote hash) (unquote fspath) (unquote path)
+ >>= fun () ->
+ loop ()
+ | "WAIT" ->
+ wait (unquote args);
+ loop ()
+ | "CHANGES" ->
+ output_changes (unquote args) >>= fun () ->
+ loop ()
+ | "RESET" ->
+ reset (unquote args);
+ loop ()
+ | _ ->
+ error (Format.sprintf "unknown command '%s'" cmd)
+
+let _ =
+watch ();
+Lwt_unix.run
+ (printf "VERSION 1\n" >>= fun () ->
+ Lwt.catch (fun () -> loop ())
+ (fun e ->
+ match e with
+ End_of_file | Unix.Unix_error (Unix.EPIPE, _, _) ->
+ Lwt.return ()
+ | _ ->
+ if !debug then Format.eprintf "%s at ." (format_exc e);
+ error ("error while communicating with Unison: " ^ format_exc e)))
+
+end
+end
Added: trunk/src/fsmonitor/watchercommon.mli
===================================================================
--- trunk/src/fsmonitor/watchercommon.mli (rev 0)
+++ trunk/src/fsmonitor/watchercommon.mli 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,35 @@
+
+val debug : bool ref
+
+val error : string -> 'a
+val format_exc : exn -> string
+
+module StringMap : Map.S with type key = string
+
+module F (M : sig type watch end) : sig
+
+ type t
+
+ val get_id : t -> int
+ val get_watch : t -> M.watch option
+ val set_watch : t -> M.watch option -> unit
+ val get_subdirs : t -> t StringMap.t
+ val is_root : t -> bool
+
+ val file_by_id : (int, t) Hashtbl.t
+ val dir_path : t -> string -> string
+
+ val signal_change :
+ float ref -> t -> string option -> [> `CREAT | `DEL ] -> unit
+ val signal_overflow : unit -> unit
+
+ module type S = sig
+ val add_watch : string -> t -> unit
+ val release_watch : t -> unit
+ val watch : unit -> unit
+ val clear_event_memory : unit -> unit
+ end
+
+ module F (M :S) : sig end
+
+end
Property changes on: trunk/src/fsmonitor/windows
___________________________________________________________________
Added: svn:ignore
+ *.cm[ix]
Added: trunk/src/fsmonitor/windows/Makefile
===================================================================
--- trunk/src/fsmonitor/windows/Makefile (rev 0)
+++ trunk/src/fsmonitor/windows/Makefile 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,24 @@
+
+FSMONITOR = $(NAME)-fsmonitor
+
+DIR=fsmonitor/windows
+FSMCAMLOBJS = \
+ ubase/rx.cmx unicode_tables.cmx unicode.cmx \
+ system/system_generic.cmx system/system_win.cmx \
+ system/win/system_impl.cmx \
+ lwt/lwt.cmx lwt/pqueue.cmx lwt/win/lwt_unix_impl.cmx lwt/lwt_unix.cmx \
+ lwt/win/lwt_win.cmx \
+ $(DIR)/shortnames.cmx fsmonitor/watchercommon.cmx $(DIR)/watcher.cmx
+FSMCOBJS = \
+ system/system_win_stubs.o lwt/lwt_unix_stubs.o $(DIR)/shortnames_stubs.o
+FSMCAMLLIBS=bigarray.cmxa unix.cmxa
+
+buildexecutable:: $(FSMONITOR)$(EXEC_EXT)
+
+$(FSMONITOR)$(EXEC_EXT): $(FSMCAMLOBJS) $(FSMCOBJS)
+ @echo Linking $@
+ $(OCAMLOPT) -verbose $(CAMLFLAGS) -o $@ $(CFLAGS) $(FSMCAMLLIBS) $^ $(CLIBS)
+
+clean::
+ rm -f $(DIR)/*.cm[iox] $(DIR)/*.o $(DIR)/*~
+ rm -f $(FSMONITOR)$(EXEC_EXT)
Added: trunk/src/fsmonitor/windows/shortnames.ml
===================================================================
--- trunk/src/fsmonitor/windows/shortnames.ml (rev 0)
+++ trunk/src/fsmonitor/windows/shortnames.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,50 @@
+(* Unison file synchronizer: src/monitoring-linux/lwt_inotify.ml *)
+(* Copyright 2012, 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 handle
+
+external findnext_short : handle -> string * string = "win_findnext_short"
+external findfirst_short : string -> (string * string) * handle =
+ "win_findfirst_short"
+external findclose : handle -> unit = "win_findclosew"
+
+let epath = System_impl.Fs.W.epath
+let path8 = System_impl.Fs.W.path8
+
+let convert (l, s) = (path8 l, path8 s)
+
+let of_file f =
+ try
+ let (m, h) = findfirst_short (epath f) in
+ findclose h;
+ Some (convert m)
+ with End_of_file ->
+ None
+
+let in_directory d =
+ let l = ref [] in
+ try
+ let (first_entry, handle) =
+ findfirst_short (epath (Filename.concat d "*")) in
+ l := [convert first_entry];
+ while true do
+ l := convert (findnext_short handle) :: !l
+ done;
+ assert false
+ with End_of_file ->
+ !l
+
Added: trunk/src/fsmonitor/windows/shortnames.mli
===================================================================
--- trunk/src/fsmonitor/windows/shortnames.mli (rev 0)
+++ trunk/src/fsmonitor/windows/shortnames.mli 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,2 @@
+val of_file : string -> (string * string) option
+val in_directory : string -> (string * string) list
Added: trunk/src/fsmonitor/windows/shortnames_stubs.c
===================================================================
--- trunk/src/fsmonitor/windows/shortnames_stubs.c (rev 0)
+++ trunk/src/fsmonitor/windows/shortnames_stubs.c 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,104 @@
+#define WINVER 0x0500
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+
+#include <windows.h>
+#include <fcntl.h>
+#include <sys/stat.h>
+
+//#include <stdio.h>
+
+#define Nothing ((value) 0)
+
+extern void win32_maperr (DWORD errcode);
+extern void uerror (char * cmdname, value arg);
+extern value win_alloc_handle (HANDLE h);
+
+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;
+}
+
+CAMLprim value win_findnext_short(value valh)
+{
+ WIN32_FIND_DATAW fileinfo;
+ BOOL retcode;
+
+ CAMLparam1(valh);
+ CAMLlocal1(valname);
+
+ do {
+ retcode = FindNextFileW(Handle_val(valh), &fileinfo);
+ if (!retcode) {
+ DWORD err = GetLastError();
+ if (err == ERROR_NO_MORE_FILES) {
+ if (! FindClose(Handle_val(valh))) {
+ win32_maperr(GetLastError());
+ uerror("closedir", Nothing);
+ }
+ raise_end_of_file();
+ } else {
+ win32_maperr(err);
+ uerror("readdir", Nothing);
+ }
+ }
+ // fwprintf (stderr, L"%d %s\n", fileinfo.cAlternateFileName[0], fileinfo.cAlternateFileName);
+ } while (fileinfo.cAlternateFileName[0] == 0);
+
+ valname = caml_alloc_tuple (2);
+ Store_field (valname, 0, copy_wstring(fileinfo.cFileName));
+ Store_field (valname, 1, copy_wstring(fileinfo.cAlternateFileName));
+
+ CAMLreturn (valname);
+}
+
+CAMLprim value win_findfirst_short(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) || (err == ERROR_FILE_NOT_FOUND))
+ raise_end_of_file();
+ else {
+ win32_maperr(err);
+ uerror("opendir", Nothing);
+ }
+ }
+ valh = win_alloc_handle(h);
+ //fwprintf (stderr, L"%d %s\n", fileinfo.cAlternateFileName[0], fileinfo.cAlternateFileName);
+ if (fileinfo.cAlternateFileName[0] != 0) {
+ valname = caml_alloc_tuple (2);
+ Store_field (valname, 0, copy_wstring(fileinfo.cFileName));
+ Store_field (valname, 1, copy_wstring(fileinfo.cAlternateFileName));
+ } else
+ valname = win_findnext_short(valh);
+ v = caml_alloc_tuple(2);
+ Store_field(v,0,valname);
+ Store_field(v,1,valh);
+ CAMLreturn (v);
+}
Added: trunk/src/fsmonitor/windows/watcher.ml
===================================================================
--- trunk/src/fsmonitor/windows/watcher.ml (rev 0)
+++ trunk/src/fsmonitor/windows/watcher.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,223 @@
+(* Unison file synchronizer: src/monitoring/windows/watcher.ml *)
+(* Copyright 2012, 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/>.
+*)
+
+(*
+LIMITATIONS
+- we do not detect when a directory below a path is moved;
+- we do not watch non-existent or non-directory roots
+
+REMARK
+ReadDirectoryChangesW fails with ERROR_INVALID_PARAMETER when
+we are not on a directory, and ERROR_ACCESS_DENIED when the directory
+is removed.
+
+Maybe we should ignore Unison temporary files
+*)
+
+let (>>=) = Lwt.bind
+
+module StringMap = Watchercommon.StringMap
+
+type watch_def =
+ { mutable handle : Lwt_win.directory_handle option;
+ mutable longname : string StringMap.t;
+ mutable shortname : string StringMap.t }
+
+module M = Watchercommon.F (struct type watch = watch_def end)
+include M
+
+(****)
+
+module Windows = struct
+
+let print_event (nm, act) =
+ Format.eprintf "%s %d at ." nm (Obj.magic act : int)
+
+let event_is_immediate (_, act) =
+ match act with
+ Lwt_win.FILE_ACTION_ADDED
+ | Lwt_win.FILE_ACTION_MODIFIED -> false
+ | Lwt_win.FILE_ACTION_REMOVED
+ | Lwt_win.FILE_ACTION_RENAMED_OLD_NAME
+ | Lwt_win.FILE_ACTION_RENAMED_NEW_NAME -> true
+
+let event_kind (_, act) =
+ match act with
+ Lwt_win.FILE_ACTION_ADDED -> `CREAT
+ | Lwt_win.FILE_ACTION_MODIFIED -> `MODIF
+ | Lwt_win.FILE_ACTION_RENAMED_NEW_NAME -> `MOVED
+ | Lwt_win.FILE_ACTION_REMOVED
+ | Lwt_win.FILE_ACTION_RENAMED_OLD_NAME -> `DEL
+
+let long_name dir nm =
+ match get_watch dir with
+ None -> nm
+ | Some w -> try StringMap.find nm w.longname with Not_found -> nm
+
+let rec follow_win_path dir path pos =
+ try
+ let i = String.index_from path pos '\\' in
+ let nm = String.sub path pos (i - pos) in
+ try
+ let dir = StringMap.find (long_name dir nm) (get_subdirs dir) in
+ follow_win_path dir path (i + 1)
+ with Not_found ->
+ if !Watchercommon.debug then
+ Format.eprintf "Ignored directory %s (%s) in path %s at ."
+ nm (long_name dir nm) path;
+ None
+ with Not_found ->
+ Some (dir, String.sub path pos (String.length path - pos))
+
+let previous_event = ref None
+let time_ref = ref (ref 0.)
+
+let clear_event_memory () = previous_event := None
+
+let flags =
+ Lwt_win.([FILE_NOTIFY_CHANGE_FILE_NAME; FILE_NOTIFY_CHANGE_DIR_NAME;
+ FILE_NOTIFY_CHANGE_ATTRIBUTES; (*FILE_NOTIFY_CHANGE_SIZE;*)
+ FILE_NOTIFY_CHANGE_LAST_WRITE; FILE_NOTIFY_CHANGE_CREATION;
+ (*FILE_NOTIFY_CHANGE_SECURITY*)])
+
+let watch_root_directory path dir =
+ let h = Lwt_win.open_directory path in
+ let rec loop () =
+ Lwt_win.readdirectorychanges h true flags >>= fun l ->
+ let time = Unix.gettimeofday () in
+ List.iter
+ (fun ((ev_path, _) as ev) ->
+ if !previous_event <> Some ev then begin
+ time_ref := ref time;
+ previous_event := Some ev;
+ if !Watchercommon.debug then print_event ev;
+ match follow_win_path dir ev_path 0 with
+ None ->
+ ()
+ | Some (subdir, nm) ->
+ let event_time =
+ if event_is_immediate ev then ref 0. else !time_ref in
+ let kind = event_kind ev in
+ let nm =
+ match kind, get_watch subdir with
+ (`CREAT | `MOVED), Some w ->
+ begin try
+ match
+ Shortnames.of_file (Filename.concat path ev_path)
+ with
+ Some (l, s) ->
+ if !Watchercommon.debug then
+ Format.eprintf "New mapping: %s -> %s at ." l s;
+ (* First remove a previous binding, if any *)
+ begin try
+ w.longname <-
+ StringMap.remove (StringMap.find l w.shortname)
+ w.longname
+ with Not_found -> () end;
+ begin try
+ w.shortname <-
+ StringMap.remove (StringMap.find s w.longname)
+ w.shortname
+ with Not_found -> () end;
+ w.shortname <- StringMap.add l s w.shortname;
+ w.longname <- StringMap.add s l w.longname;
+ l
+ | None ->
+ long_name subdir nm
+ with Unix.Unix_error _ as e ->
+ if !Watchercommon.debug then
+ Format.eprintf
+ "Error while getting file short name: %s at ."
+ (Watchercommon.format_exc e);
+ long_name subdir nm
+ end
+ | `DEL, Some w ->
+ let l = long_name subdir nm in
+ begin try
+ let s = StringMap.find l w.shortname in
+ w.shortname <- StringMap.remove l w.shortname;
+ w.longname <- StringMap.remove s w.longname
+ with Not_found -> () end;
+ l
+ | _ ->
+ long_name subdir nm
+ in
+ if
+ not (kind = `MODIF && StringMap.mem nm (get_subdirs subdir))
+ then
+ signal_change event_time subdir (Some nm) kind
+ end else
+ !time_ref := time)
+ l;
+ if l = [] then begin
+ if !Watchercommon.debug then Format.eprintf "OVERFLOW at .";
+ signal_overflow ()
+ end;
+ loop ()
+ in
+ ignore (Lwt.catch loop
+ (fun e ->
+ set_watch dir None;
+ begin try Lwt_win.close_dir h with Unix.Unix_error _ -> () end;
+ if !Watchercommon.debug then
+ Format.eprintf "Error while reading directory changes: %s at ."
+ (Watchercommon.format_exc e); Lwt.return ()));
+ h
+
+let add_watch path file =
+ if get_watch file = None then begin
+ let watch_info =
+ { handle = None;
+ longname = StringMap.empty; shortname = StringMap.empty } in
+ set_watch file (Some watch_info);
+ if is_root file then begin
+ try
+ watch_info.handle <- Some (watch_root_directory path file)
+ with Unix.Unix_error _ as e ->
+ if !Watchercommon.debug then
+ Format.eprintf
+ "Error while starting to watch for changes: %s at ."
+ (Watchercommon.format_exc e)
+ end;
+ let mapping =
+ try Shortnames.in_directory path with Unix.Unix_error _ -> [] in
+ watch_info.longname <-
+ List.fold_left
+ (fun m (l, s) ->
+ if !Watchercommon.debug then Format.eprintf "%s -> %s at ." l s;
+ StringMap.add s l m)
+ StringMap.empty mapping;
+ watch_info.shortname <-
+ List.fold_left (fun m (l, s) -> StringMap.add l s m)
+ StringMap.empty mapping
+ end
+
+let release_watch file =
+ match get_watch file with
+ Some {handle = Some h} ->
+ set_watch file None;
+ begin try Lwt_win.close_dir h with Unix.Unix_error _ -> () end
+ | _ ->
+ set_watch file None
+
+let watch () = () (* No global loop under Windows... *)
+
+end
+
+(****)
+
+include F(Windows)
Added: trunk/src/fswatch.ml
===================================================================
--- trunk/src/fswatch.ml (rev 0)
+++ trunk/src/fswatch.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,439 @@
+(* Unison file synchronizer: src/fswatch.ml *)
+(* Copyright 1999-2012, 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/>.
+*)
+
+(*
+Protocol description
+====================
+
+ The file monitoring process receives commands from stdin and
+ responds to stdout. Commands and responds are single lines composed
+ of an identifier followed by a single space and a space separated
+ list of arguments. Arguments are percent-encoded. At the minimum,
+ spaces and newlines must be escaped. The two processes should accept
+ any other escaped character.
+
+ Unison and the child process starts by indicating the protocol
+ version they support. At the moment, they should just output the
+ line 'VERSION 1'.
+
+ Debugging is enabled by the 'DEBUG' command.
+
+ At any time, the child process can signal an error by sending an
+ "ERROR msg" message.
+
+ When Unison start scanning a part of the replica, it emits command:
+ 'START hash fspath path', thus indicating the archive hash (that
+ uniquely determines the replica) the replica's fspath and the path
+ where the scanning process starts. The child process should start
+ monitoring this location, then acknowledge the command by sending an
+ 'OK' response.
+ When Unison starts scanning a directory, it emits the command
+ 'DIR path1', where 'path1' is relative to the path given by the
+ START command (the location of the directory can be obtained by
+ concatenation of 'fspath', 'path', and 'path1'). The child process
+ should then start monitoring the directory, before sending an 'OK'
+ response.
+ When Unison encounters a followed link, it emits the command
+ 'LINK path1'. The child process is expected to start monitoring
+ the link target before replying by 'OK'.
+ Unison signals that it is done scanning the part of the replica
+ described by the START process by emitting the 'DONE' command. The
+ child process should not respond to this command.
+
+ Unison can ask for a list of paths containing changes in a given
+ replica by sending the 'CHANGES hash' command. The child process
+ responds by a sequence of 'RECURSIVE path' responses, followed by a
+ 'DONE' response. These paths should be relative to the replica
+ 'fspath'. The child process will not have to report this changes any
+ more: it can consider that Unison has taken this information into
+ account once and for all. Thus, it is expected to thereafter report
+ only further changes.
+
+ Unison can wait for changes in a replica by emitting a 'WAIT hash'
+ command. It can watch several replicas by sending a serie of these
+ commands. The child process is expected to respond once, by a
+ 'CHANGE hash1 ... hash2' response that lists the changed replicas
+ among those included in a 'WAIT' command, when changes are
+ available. It should cancel pending waits when any other command is
+ received.
+
+ Finally, the command 'RESET hash' tells the child process to stop
+ watching the given replica. In particular, it can discard any
+ pending change information for this replica.
+
+ UNISON CLIENT-SERVER PROTOCOL CHANGE!
+
+ - =====> fix [associate] function <================
+*)
+
+let debug = Util.debug "fswatch"
+let debugverbose = Trace.debug "fswatch+"
+
+let (>>=) = Lwt.bind
+
+let rec really_write o s pos len =
+ Lwt_unix.write o s pos len >>= fun l ->
+ if l = len then
+ Lwt.return ()
+ else
+ really_write o s (pos + l) (len - l)
+
+let split_on_space s =
+ try
+ let i = String.index s ' ' in
+ (String.sub s 0 i,
+ String.sub s (i + 1) (String.length s - i - 1))
+ with Not_found ->
+ (s, "")
+
+let disallowed_char c =
+ match c with
+ 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '_' | '.' | '~'
+ | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&'
+ | '=' | '+' | '$' | ',' | '/' | '?' | '#' | '[' | ']' ->
+ false
+ | _ ->
+ true
+
+let quote s =
+ let l = String.length s in
+ let n = ref 0 in
+ for i = 0 to l - 1 do if disallowed_char s.[i] then incr n done;
+ if !n = 0 then s else begin
+ let q = String.create (l + 2 * !n) in
+ let j = ref 0 in
+ let hex = "0123456789ABCDEF" in
+ for i = 0 to l - 1 do
+ let c = s.[i] in
+ if disallowed_char s.[i] then begin
+ q.[!j] <- '%';
+ q.[!j + 1] <- hex.[Char.code c lsr 4];
+ q.[!j + 2] <- hex.[Char.code c land 15];
+ j := !j + 3
+ end else begin
+ q.[!j] <- c;
+ incr j
+ end
+ done;
+ q
+ end
+
+let unquote s =
+ let l = String.length s in
+ let n = ref 0 in
+ for i = 0 to l - 1 do if s.[i] = '%' then incr n done;
+ if !n = 0 then s else begin
+ let hex_char c =
+ match c with
+ '0'..'9' -> Char.code c - Char.code '0'
+ | 'a'..'f' -> Char.code c - Char.code 'a' + 10
+ | 'A'..'F' -> Char.code c - Char.code 'A' + 10
+ | _ -> invalid_arg "unquote"
+ in
+ let u = String.create (l - 2 * !n) in
+ let j = ref 0 in
+ for i = 0 to l - 2 * !n - 1 do
+ let c = s.[!j] in
+ if c = '%' then begin
+ u.[i] <- Char.chr ((hex_char s.[!j + 1]) lsl 4 + hex_char s.[!j + 2]);
+ j := !j + 3
+ end else begin
+ u.[i] <- c;
+ incr j
+ end
+ done;
+ u
+ end
+
+module Cond = struct
+ type t = unit Lwt.t list ref
+ let make () = ref []
+ let signal s =
+ let wl = !s in
+ s := [];
+ List.iter (fun w -> Lwt.wakeup w ()) wl
+ let wait s =
+ let t = Lwt.wait () in
+ s := t :: !s;
+ t
+end
+
+(****)
+
+let useWatcher =
+ Prefs.createBool "watch" true
+ "!when set, use a file watcher process to detect changes"
+ "Unison uses a file watcher process, when available, to detect filesystem \
+ changes; this is used to speed up update detection, and for continuous \
+ synchronization (\\verb|-repeat watch| preference. Setting this flag to \
+ false disable the use of this process."
+
+let printf o fmt =
+ Printf.ksprintf
+ (fun s ->
+ debugverbose (fun () -> Util.msg "<< %s" s);
+ Util.convertUnixErrorsToFatal
+ "sending command to filesystem watcher"
+ (fun () -> Lwt_unix.run (really_write o s 0 (String.length s))))
+ fmt
+
+let read_line i =
+ let b = Buffer.create 160 in
+ let buf = String.create 160 in
+ let start = ref 0 in
+ let last = ref 0 in
+ let rec read () =
+ begin
+ if !start = !last then begin
+ Lwt_unix.read i buf 0 160 >>= fun l ->
+ if l = 0 then
+ raise (Util.Fatal "Filesystem watcher died unexpectively");
+ start := 0; last := l;
+ Lwt.return ()
+ end else
+ Lwt.return ()
+ end >>= fun () ->
+ try
+ let i = String.index_from buf !start '\n' in
+ if i >= !last then raise Not_found;
+ Buffer.add_substring b buf !start (i - !start);
+ start := i + 1;
+ let s = Buffer.contents b in
+ Buffer.clear b;
+ debugverbose (fun() -> Util.msg ">> %s\n" s);
+ Lwt.return s
+ with Not_found ->
+ Buffer.add_substring b buf !start (!last - !start);
+ start := 0; last := 0;
+ read ()
+ in
+ read
+
+(****)
+
+let path =
+ List.map System.fspathFromString
+ (try
+ Str.split (Str.regexp (if Util.osType = `Win32 then ";" else ":"))
+ (Sys.getenv "PATH")
+ with Not_found ->
+ [])
+
+let search_in_path ?(path = path) name =
+ System.fspathConcat
+ (List.find (fun dir -> System.file_exists (System.fspathConcat dir name))
+ path)
+ name
+
+let exec_path =
+ try
+ (* Linux *)
+ [System.fspathFromString (Unix.readlink "/proc/self/exe")]
+ with Unix.Unix_error _ ->
+ let name = (System.argv ()).(0) in
+ if not (Filename.is_relative name) then
+ [System.fspathFromString name]
+ else if Filename.is_implicit name then
+ try
+ [search_in_path name]
+ with Not_found ->
+ []
+ else
+ [System.fspathConcat (System.getcwd ()) name]
+
+let exec_dir = List.map System.fspathDirname exec_path
+
+let watcher =
+ lazy
+ (let suffix = if Util.osType = `Win32 then ".exe" else "" in
+ System.fspathToString
+ (try
+ search_in_path ~path:(exec_dir @ path)
+ ("unison-fsmonitor-" ^ Uutil.myMajorVersion ^ suffix)
+ with Not_found ->
+ search_in_path ~path:(exec_dir @ path)
+ ("unison-fsmonitor" ^ suffix)))
+
+type 'a exn_option = Value of 'a | Exn of exn | Nothing
+let has_changes = Cond.make ()
+let has_line = Cond.make ()
+let line_read = Cond.make ()
+let last_line = ref Nothing
+
+let rec reader read_line =
+ read_line () >>= fun l ->
+ Cond.signal has_changes;
+ if l = "CHANGES" then begin
+ reader read_line
+ end else begin
+ last_line := Value l;
+ Cond.signal has_line;
+ Cond.wait line_read >>= fun () ->
+ reader read_line
+ end
+
+let conn = ref None
+
+let startProcess () =
+ try
+ let w = Lazy.force watcher in
+ let (i1,o1) = Lwt_unix.pipe_out () in
+ let (i2,o2) = Lwt_unix.pipe_in () in
+ Lwt_unix.set_close_on_exec i2;
+ Lwt_unix.set_close_on_exec o1;
+ Util.convertUnixErrorsToFatal "starting filesystem watcher" (fun () ->
+ ignore (System.create_process w [|w|] i1 o2 Unix.stderr));
+ Unix.close i1; Unix.close o2;
+ ignore
+ (Lwt.catch (fun () -> reader (read_line i2))
+ (fun e -> last_line := Exn e; Cond.signal has_line; Lwt.return ()));
+ conn := Some o1;
+ true
+ with Not_found ->
+ false
+
+let rec emitCmd fmt =
+ match !conn with
+ Some o -> begin try printf o fmt with e -> conn := None; raise e end
+ | None -> assert false
+
+let rec readLine () =
+ match !last_line with
+ Nothing -> Lwt_unix.run (Cond.wait has_line); readLine ()
+ | Value l -> last_line := Nothing; Cond.signal line_read; l
+ | Exn e -> conn := None; raise e
+
+let badResponse cmd args expected =
+ conn := None;
+ if cmd = "ERROR" then
+ raise (Util.Fatal ("Filesystem watcher error: " ^ (unquote args) ^ "\n\
+ The watcher can be disabled by setting preference \
+ 'watch' to false"))
+ else
+ raise
+ (Util.Fatal
+ (Format.sprintf
+ "Unexpected response '%s %s' from the filesystem watcher \
+ (expected %s)" cmd args expected))
+
+let readAck () =
+ let (cmd, args) = split_on_space (readLine ()) in
+ if cmd <> "OK" then badResponse cmd args "OK"
+
+let readVersion () =
+ let (cmd, args) = split_on_space (readLine ()) in
+ if cmd <> "VERSION" then badResponse cmd args "VERSION"
+
+let exchangeVersions () =
+ let res = startProcess () in
+ if res then begin
+ emitCmd "VERSION 1\n";
+ debug (fun () -> Util.msg "debugging enabled\n"; emitCmd "DEBUG\n");
+ readVersion ()
+ end;
+ res
+
+(****)
+
+type archiveHash = string
+
+let scanning = ref false
+let start_path = ref ""
+
+let relpath path =
+ let s2 = Path.toString path in
+ let l1 = String.length !start_path in
+ let l2 = String.length s2 in
+ if l1 = 0 then begin
+ s2
+ end else if l1 = l2 then begin
+ assert (s2 = !start_path);
+ ""
+ end else begin
+ assert
+ ((l2 >= l1 + 1) && String.sub s2 0 l1 = !start_path && s2.[l1] = '/');
+ String.sub s2 (l1 + 1) (l2 - l1 - 1)
+ end
+
+let started () = !conn <> None
+
+let startScanning hash fspath path =
+ if started () then begin
+ emitCmd "START %s %s %s\n"
+ (quote hash)
+ (quote (Fspath.toString fspath)) (quote (Path.toString path));
+ readAck ();
+ scanning := true;
+ start_path := Path.toString path
+ end
+
+let scanDirectory path =
+ if !scanning then begin
+ emitCmd "DIR %s\n" (quote (relpath path));
+ readAck ()
+ end
+
+let followLink path =
+ if !scanning then begin
+ emitCmd "LINK %s\n" (quote (relpath path));
+ readAck ()
+ end
+
+let stopScanning () =
+ if !scanning then begin
+ scanning := false;
+ emitCmd "DONE\n"
+ end
+
+let start hash =
+ if not (Prefs.read useWatcher) then
+ false
+ else if not (started ()) then
+ exchangeVersions ()
+ else begin
+ emitCmd "RESET %s\n" (quote hash);
+ true
+ end
+
+let wait hash =
+ if started () then begin
+ let res = Cond.wait has_changes in
+ emitCmd "WAIT %s\n" (quote hash);
+ res
+ end else
+ raise (Util.Fatal "No file monitoring helper program found")
+
+(****)
+
+let rec parseChanges l =
+ let (cmd, args) = split_on_space (readLine ()) in
+ match cmd with
+ "CHANGES" ->
+ parseChanges l
+ | "RECURSIVE" ->
+ parseChanges (Path.fromString (unquote args) :: l)
+ | "DONE" ->
+ List.rev l
+ | other ->
+ badResponse other args "RECURSIVE or DONE"
+
+let getChanges hash =
+ if started () then begin
+ emitCmd "CHANGES %s\n" (quote hash);
+ parseChanges []
+ end else
+ raise (Util.Fatal "No file monitoring helper program found")
Added: trunk/src/fswatch.mli
===================================================================
--- trunk/src/fswatch.mli (rev 0)
+++ trunk/src/fswatch.mli 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,18 @@
+(* Unison file synchronizer: src/fswatch.mli *)
+(* Copyright 1999-2012, Benjamin C. Pierce (see COPYING for details) *)
+
+type archiveHash = string
+
+val start : archiveHash -> bool
+
+val startScanning : archiveHash -> Fspath.t -> Path.local -> unit
+val stopScanning : unit -> unit
+val scanDirectory : Path.local -> unit
+val followLink : Path.local -> unit
+
+val wait : archiveHash -> unit Lwt.t
+val getChanges : archiveHash -> Path.t list
+
+(****)
+
+val useWatcher : bool Prefs.t
Modified: trunk/src/fswatchold.ml
===================================================================
--- trunk/src/fswatchold.ml 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/fswatchold.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -21,14 +21,6 @@
(* FIX: the names of the paths being watched should get included
in the name of the watcher's state file *)
-let useWatcher =
- Prefs.createBool "watch" true
- "!when set, use a file watcher process to detect changes"
- "Unison uses a file watcher process, when available, to detect filesystem \
- changes; this is used to speed up update detection, and for continuous \
- synchronization (\\verb|-repeat watch| preference. Setting this flag to \
- false disable the use of this process."
-
let debug = Util.debug "fswatch"
let watchinterval = 5
@@ -72,6 +64,7 @@
chars: Buffer.t;
mutable lines: string list}
let watchers : watcherinfo RootMap.t ref = ref RootMap.empty
+let newWatchers = ref StringSet.empty
let trim_duplicates l =
let rec loop l = match l with
@@ -120,16 +113,23 @@
readAvailableLinesFromWatcher wi
let getChanges archHash =
+ if StringSet.mem archHash !newWatchers then
+ Fswatch.getChanges archHash
+ else begin
let wi = RootMap.find archHash !watchers in
readChanges wi;
let res = wi.lines in
wi.lines <- [];
List.map Path.fromString (trim_duplicates res)
+ end
let start archHash fspath =
- if not (Prefs.read useWatcher) then
+ if not (Prefs.read Fswatch.useWatcher) then
false
- else if not (RootMap.mem archHash !watchers) then begin
+ else if Fswatch.start archHash then begin
+ newWatchers := StringSet.add archHash !newWatchers;
+ true
+ end else if not (RootMap.mem archHash !watchers) then begin
(* Watcher process not running *)
match watchercmd archHash (Fspath.toString fspath) with
Some (changefile,cmd) ->
@@ -150,7 +150,9 @@
end
let wait archHash =
- if not (RootMap.mem archHash !watchers) then
+ if StringSet.mem archHash !newWatchers then
+ Fswatch.wait archHash
+ else if not (RootMap.mem archHash !watchers) then
raise (Util.Fatal "No file monitoring helper program found")
else begin
let wi = RootMap.find archHash !watchers in
Modified: trunk/src/lwt/lwt_unix_stubs.c
===================================================================
--- trunk/src/lwt/lwt_unix_stubs.c 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/lwt/lwt_unix_stubs.c 2012-08-09 14:30:22 UTC (rev 506)
@@ -69,9 +69,10 @@
#define WRITE 1
#define READ_OVERLAPPED 2
#define WRITE_OVERLAPPED 3
-
-static char * action_name[4] = {
- "read", "write", "read(overlapped)", "write(overlapped)"
+#define READDIRECTORYCHANGES 4
+static char * action_name[5] = {
+ "read", "write", "read(overlapped)", "write(overlapped)",
+ "ReadDirectoryChangesW"
};
static value completionCallback;
@@ -145,6 +146,7 @@
static DWORD CALLBACK helper_thread (void * param) {
D(printf("Helper thread created\n"));
while (1) SleepEx(INFINITE, TRUE);
+ return 0;
}
static VOID CALLBACK exit_thread(ULONG_PTR param) {
@@ -596,3 +598,90 @@
CAMLreturn (Val_unit);
}
*/
+
+static int notify_filter_flags[8] = {
+ FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME,
+ FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE,
+ FILE_NOTIFY_CHANGE_LAST_WRITE, FILE_NOTIFY_CHANGE_LAST_ACCESS,
+ FILE_NOTIFY_CHANGE_CREATION, FILE_NOTIFY_CHANGE_SECURITY
+};
+
+CAMLprim value win_readdirtorychanges
+(value fd_val, value buf_val, value recursive, value flags, value id_val) {
+ CAMLparam5(fd_val, buf_val, recursive, flags, id_val);
+ struct caml_bigarray *buf_arr = Bigarray_val(buf_val);
+ long id = Long_val(id_val);
+ HANDLE fd = Handle_val(fd_val);
+ char * buf = Array_data (buf_arr, 0);
+ long len = buf_arr->dim[0];
+ long action = READDIRECTORYCHANGES;
+ BOOL res;
+ long err;
+ int notify_filter = convert_flag_list(flags, notify_filter_flags);
+ completionData * d = GlobalAlloc(GPTR, sizeof(completionData));
+ if (d == NULL) {
+ errno = ENOMEM;
+ uerror(action_name[action], Nothing);
+ }
+ d->id = id;
+ d->action = action;
+
+ D(printf("Starting %s: id %ld, len %ld\n", action_name[action], id, len));
+
+ res = ReadDirectoryChangesW (fd, buf, len, Bool_val(recursive),
+ notify_filter, NULL, &(d->overlapped),
+ overlapped_completion);
+
+ if (!res) {
+ err = GetLastError ();
+ if (err != ERROR_IO_PENDING) {
+ win32_maperr (err);
+ D(printf("Action %s failed: id %ld -> err %d (errCode %ld)\n",
+ action_name[action], id, errno, err));
+ uerror("ReadDirectoryChangesW", Nothing);
+ }
+ }
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value win_parse_directory_changes (value buf_val) {
+ CAMLparam1(buf_val);
+ CAMLlocal4(lst, tmp, elt, filename);
+ struct caml_bigarray *buf_arr = Bigarray_val(buf_val);
+ char * pos = Array_data (buf_arr, 0);
+ FILE_NOTIFY_INFORMATION * entry;
+
+ lst = Val_long(0);
+ while (1) {
+ entry = (FILE_NOTIFY_INFORMATION *)pos;
+ elt = caml_alloc_tuple(2);
+ filename = caml_alloc_string(entry->FileNameLength);
+ memmove(String_val(filename), entry->FileName, entry->FileNameLength);
+ Store_field (elt, 0, filename);
+ Store_field (elt, 1, Val_long(entry->Action - 1));
+ tmp = caml_alloc_tuple(2);
+ Store_field (tmp, 0, elt);
+ Store_field (tmp, 1, lst);
+ lst = tmp;
+ if (entry->NextEntryOffset == 0) break;
+ pos += entry->NextEntryOffset;
+ }
+ CAMLreturn(lst);
+}
+
+CAMLprim value win_open_directory (value path, value wpath) {
+ CAMLparam2 (path, wpath);
+ HANDLE h;
+ h = CreateFileW((LPCWSTR) String_val(wpath),
+ FILE_LIST_DIRECTORY,
+ FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED,
+ NULL);
+ if (h == INVALID_HANDLE_VALUE) {
+ win32_maperr (GetLastError ());
+ uerror("open", path);
+ }
+ CAMLreturn(win_alloc_handle(h));
+}
Modified: trunk/src/lwt/win/lwt_unix_impl.ml
===================================================================
--- trunk/src/lwt/win/lwt_unix_impl.ml 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/lwt/win/lwt_unix_impl.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -160,6 +160,7 @@
begin match action with
`Write -> ()
| `Read (s, pos) -> if len > 0 then blit_buffer_to_string buf 0 s pos len
+ | `Readdirectorychanges -> ()
end;
IntTbl.remove ioInFlight id;
release_id id;
@@ -643,3 +644,46 @@
type lwt_in_channel
let input_line _ = assert false (*XXXXX*)
let intern_in_channel _ = assert false (*XXXXX*)
+
+(***)
+
+type directory_handle = Unix.file_descr
+
+external open_dir : string -> string -> directory_handle = "win_open_directory"
+let open_directory f = open_dir f (System_impl.Fs.W.epath f)
+
+type notify_filter_flag =
+ FILE_NOTIFY_CHANGE_FILE_NAME | FILE_NOTIFY_CHANGE_DIR_NAME
+ | FILE_NOTIFY_CHANGE_ATTRIBUTES | FILE_NOTIFY_CHANGE_SIZE
+ | FILE_NOTIFY_CHANGE_LAST_WRITE | FILE_NOTIFY_CHANGE_LAST_ACCESS
+ | FILE_NOTIFY_CHANGE_CREATION | FILE_NOTIFY_CHANGE_SECURITY
+
+external start_read_dir_changes :
+ directory_handle -> buffer -> bool -> notify_filter_flag list -> int -> unit =
+ "win_readdirtorychanges"
+
+type file_action =
+ FILE_ACTION_ADDED | FILE_ACTION_REMOVED
+ | FILE_ACTION_MODIFIED | FILE_ACTION_RENAMED_OLD_NAME
+ | FILE_ACTION_RENAMED_NEW_NAME
+
+external parse_directory_changes : buffer -> (string * file_action) list
+ = "win_parse_directory_changes"
+
+let readdirectorychanges ch recursive flags =
+if !d then Format.eprintf "Start reading directory changes at .";
+ let id = acquire_id () in
+ let buf = acquire_buffer () in
+ let res = Lwt.wait () in
+ IntTbl.add ioInFlight id (`Readdirectorychanges, buf, res);
+ start_read_dir_changes ch buf recursive flags id;
+if !d then Format.eprintf "Reading started at .";
+ Lwt.bind res (fun len ->
+ if len = 0 then
+ Lwt.return []
+ else
+ Lwt.return (List.rev_map (fun (nm, act) ->
+ (System_impl.Fs.W.path8 nm, act))
+ (parse_directory_changes buf)))
+
+let close_dir = Unix.close
Added: trunk/src/lwt/win/lwt_win.ml
===================================================================
--- trunk/src/lwt/win/lwt_win.ml (rev 0)
+++ trunk/src/lwt/win/lwt_win.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1 @@
+include Lwt_unix_impl
Added: trunk/src/lwt/win/lwt_win.mli
===================================================================
--- trunk/src/lwt/win/lwt_win.mli (rev 0)
+++ trunk/src/lwt/win/lwt_win.mli 2012-08-09 14:30:22 UTC (rev 506)
@@ -0,0 +1,20 @@
+type notify_filter_flag =
+ FILE_NOTIFY_CHANGE_FILE_NAME | FILE_NOTIFY_CHANGE_DIR_NAME
+ | FILE_NOTIFY_CHANGE_ATTRIBUTES | FILE_NOTIFY_CHANGE_SIZE
+ | FILE_NOTIFY_CHANGE_LAST_WRITE | FILE_NOTIFY_CHANGE_LAST_ACCESS
+ | FILE_NOTIFY_CHANGE_CREATION | FILE_NOTIFY_CHANGE_SECURITY
+
+type file_action =
+ FILE_ACTION_ADDED | FILE_ACTION_REMOVED
+ | FILE_ACTION_MODIFIED | FILE_ACTION_RENAMED_OLD_NAME
+ | FILE_ACTION_RENAMED_NEW_NAME
+
+type directory_handle
+
+(* Returns an empty list in case of overflow. *)
+val readdirectorychanges :
+ directory_handle -> bool -> notify_filter_flag list ->
+ (string * file_action) list Lwt.t
+
+val open_directory : string -> directory_handle
+val close_dir : directory_handle -> unit
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/mkProjectInfo.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -80,3 +80,4 @@
+
Modified: trunk/src/system/system_win_stubs.c
===================================================================
--- trunk/src/system/system_win_stubs.c 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/system/system_win_stubs.c 2012-08-09 14:30:22 UTC (rev 506)
@@ -1,3 +1,5 @@
+#define WINVER 0x0500
+
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
@@ -3,6 +5,4 @@
#include <caml/fail.h>
-#define WINVER 0x0500
-
#include <windows.h>
#include <fcntl.h>
Modified: trunk/src/uicommon.ml
===================================================================
--- trunk/src/uicommon.ml 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/uicommon.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -93,22 +93,10 @@
("Setting this preference causes the text-mode interface to synchronize "
^ "repeatedly, rather than doing it just once and stopping. If the "
^ "argument is a number, Unison will pause for that many seconds before "
- ^ "beginning again.")
+ ^ "beginning again. When the argument is \\verb|watch|, Unison relies on "
+ ^ "an external file monitoring process to synchronize whenever a change "
+ ^ "happens.")
-(* ^ "If the argument is a path, Unison will wait for the "
- ^ "file at this path---called a {\\em changelog}---to "
- ^ "be modified (on either the client or the server "
- ^ "machine), read the contents of the changelog (which should be a newline-"
- ^ "separated list of paths) on both client and server, "
- ^ "combine the results, "
- ^ "and start again, using the list of paths read from the changelogs as the "
- ^ " '-path' preference for the new run. The idea is that an external "
- ^ "process will watch the filesystem and, when it thinks something may have "
- ^ "changed, write the changed pathname to its local changelog where Unison "
- ^ "will find it the next time it looks. If the changelogs have not been "
- ^ "modified, Unison will wait, checking them again every few seconds."
-*)
-
let retry =
Prefs.createInt "retry" 0
"!re-try failed synchronizations N times (text ui only)"
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2012-08-09 14:22:34 UTC (rev 505)
+++ trunk/src/update.ml 2012-08-09 14:30:22 UTC (rev 506)
@@ -1460,6 +1460,7 @@
bool * bool
=
showStatusDir path;
+ Fswatch.scanDirectory path;
let skip =
Pred.test immutable (Path.toString path) &&
not (Pred.test immutablenot (Path.toString path)) in
@@ -1780,7 +1781,10 @@
NoUpdates)
| _ ->
showStatus scanInfo here;
- buildUpdateRec archive fspath here scanInfo
+ Fswatch.startScanning scanInfo.archHash fspath here;
+ let res = buildUpdateRec archive fspath here scanInfo in
+ Fswatch.stopScanning ();
+ res
(* Compute the updates for [path] against archive. Also returns an
archive, which is the old archive with time stamps updated
More information about the Unison-hackers
mailing list