[Unison-hackers] [unison-svn] r506 - in trunk/src: . fsmonitor fsmonitor/linux fsmonitor/windows lwt lwt/win system
Benjamin C. Pierce
bcpierce at cis.upenn.edu
Thu Aug 9 18:32:27 EDT 2012
This is extremely cool!
Any idea how hard it is to adapt the linux one to OSX?
- B
On Aug 9, 2012, at 10:30 AM, vouillon at seas.upenn.edu wrote:
> 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
>
> _______________________________________________
> Unison-hackers mailing list
> Unison-hackers at lists.seas.upenn.edu
> http://lists.seas.upenn.edu/mailman/listinfo/unison-hackers
More information about the Unison-hackers
mailing list