From vouillon at seas.upenn.edu Tue Aug 7 12:24:45 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Tue, 7 Aug 2012 12:24:45 -0400 Subject: [Unison-hackers] [unison-svn] r499 - in trunk/src: . lwt/generic Message-ID: <201208071624.q77GOj4K027847@yaws.seas.upenn.edu> Author: vouillon Date: 2012-08-07 12:24:45 -0400 (Tue, 07 Aug 2012) New Revision: 499 Modified: trunk/src/RECENTNEWS trunk/src/lwt/generic/lwt_unix_impl.ml trunk/src/mkProjectInfo.ml trunk/src/test.ml Log: * Fix bug in Lwt_unix.sleep Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2012-05-24 10:22:14 UTC (rev 498) +++ trunk/src/RECENTNEWS 2012-08-07 16:24:45 UTC (rev 499) @@ -1,3 +1,8 @@ +CHANGES FROM VERSION 2.45.11 + +* Fix bug in Lwt_unix.sleep + +------------------------------- CHANGES FROM VERSION 2.45.9 * Added some more debugging code in transfer.ml Modified: trunk/src/lwt/generic/lwt_unix_impl.ml =================================================================== --- trunk/src/lwt/generic/lwt_unix_impl.ml 2012-05-24 10:22:14 UTC (rev 498) +++ trunk/src/lwt/generic/lwt_unix_impl.ml 2012-08-07 16:24:45 UTC (rev 499) @@ -128,8 +128,10 @@ ([], [], []) else try - let res = Unix.select infds outfds [] delay in - if delay > 0. && !now <> -1. then now := !now +. delay; + let (readers, writers, _) as res = + Unix.select infds outfds [] delay in + if delay > 0. && !now <> -1. && readers = [] && writers = [] then + now := !now +. delay; res with Unix.Unix_error (Unix.EINTR, _, _) -> Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2012-05-24 10:22:14 UTC (rev 498) +++ trunk/src/mkProjectInfo.ml 2012-08-07 16:24:45 UTC (rev 499) @@ -73,3 +73,4 @@ + Modified: trunk/src/test.ml =================================================================== --- trunk/src/test.ml 2012-05-24 10:22:14 UTC (rev 498) +++ trunk/src/test.ml 2012-08-07 16:24:45 UTC (rev 499) @@ -370,7 +370,7 @@ check "4" R2 (Dir ["x", File "foo"]); ); - raise (Util.Fatal "Skipping some tests -- remove me!\n"); + (raise (Util.Fatal "Skipping some tests -- remove me!\n") : unit); if bothRootsLocal then runtest "backups 1 (local)" ["backup = Name *"] (fun() -> From vouillon at seas.upenn.edu Tue Aug 7 12:33:59 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Tue, 7 Aug 2012 12:33:59 -0400 Subject: [Unison-hackers] [unison-svn] r500 - trunk/src Message-ID: <201208071634.q77GY0aI028148@yaws.seas.upenn.edu> Author: vouillon Date: 2012-08-07 12:33:59 -0400 (Tue, 07 Aug 2012) New Revision: 500 Modified: trunk/src/RECENTNEWS trunk/src/fsmonitor.py trunk/src/mkProjectInfo.ml trunk/src/uitext.ml Log: * fsmonitor.py: fixed busy wait under Windows * fsmonitor.py: make sure this helper program exits when Unison terminates (now, fsmonitor.py exits when stdin is closed, and Unison redirects stdin) Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2012-08-07 16:24:45 UTC (rev 499) +++ trunk/src/RECENTNEWS 2012-08-07 16:33:59 UTC (rev 500) @@ -1,3 +1,10 @@ +CHANGES FROM VERSION 2.45.12 + +* fsmonitor.py: fixed busy wait under Windows +* fsmonitor.py: make sure this helper program exits when Unison terminates + (now, fsmonitor.py exits when stdin is closed, and Unison redirects stdin) + +------------------------------- CHANGES FROM VERSION 2.45.11 * Fix bug in Lwt_unix.sleep Modified: trunk/src/fsmonitor.py =================================================================== --- trunk/src/fsmonitor.py 2012-08-07 16:24:45 UTC (rev 499) +++ trunk/src/fsmonitor.py 2012-08-07 16:33:59 UTC (rev 500) @@ -11,8 +11,9 @@ import sys import os import stat +import threading from optparse import OptionParser -from time import time +from time import time, sleep def mydebug(fmt, *args, **kwds): if not op.debug: @@ -375,15 +376,16 @@ #now we should know what to do: build a file directory list #I assume here, that unison takes a flag for recursive scans - if recursive: - #we have to check all subdirectories - if isinstance(path,list): - #we have to check all base paths - allpathsrecursive = [p + '\tr'] - result.extend(path) - else: - result.append(path+'\tr') - else: +#JV: commented out (not implemented by Unison) +# if recursive: +# #we have to check all subdirectories +# if isinstance(path,list): +# #we have to check all base paths +# allpathsrecursive = [p + '\tr'] +# result.extend(path) +# else: +# result.append(path+'\tr') +# else: #just add the path #result.append(path) #try to find out what has changed @@ -492,7 +494,6 @@ if sys.platform == 'win32': import win32file import win32con - import threading FILE_LIST_DIRECTORY = 0x0001 @@ -538,7 +539,7 @@ try: while 1: - pass + sleep(3600) except KeyboardInterrupt: print "Cleaning up." @@ -658,6 +659,14 @@ mymesg('failed to open output file. STOP.') exit(1) + #stop watching when stdin is closed + def exitThread(): + while sys.stdin.readline(): pass + os._exit(0) + t = threading.Thread(target=exitThread) + t.setDaemon(True) + t.start() + if sys.platform=='darwin': macosxwatcher() elif sys.platform.startswith('linux'): Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2012-08-07 16:24:45 UTC (rev 499) +++ trunk/src/mkProjectInfo.ml 2012-08-07 16:33:59 UTC (rev 500) @@ -74,3 +74,4 @@ + Modified: trunk/src/uitext.ml =================================================================== --- trunk/src/uitext.ml 2012-08-07 16:24:45 UTC (rev 499) +++ trunk/src/uitext.ml 2012-08-07 16:33:59 UTC (rev 500) @@ -813,7 +813,7 @@ let (changefile,cmd) = watchercmd r in debug (fun() -> Util.msg "Starting watcher on root %s\n" (Common.root2string r)); - let _ = System.open_process_in cmd in + let _ = System.open_process_out cmd in let wi = {file = changefile; ch = ref None; lines = ref []; chars = ref ""} in watchers := RootMap.add r wi !watchers; From vouillon at seas.upenn.edu Tue Aug 7 12:57:52 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Tue, 7 Aug 2012 12:57:52 -0400 Subject: [Unison-hackers] [unison-svn] r501 - trunk/src Message-ID: <201208071657.q77Gvqmp028886@yaws.seas.upenn.edu> Author: vouillon Date: 2012-08-07 12:57:51 -0400 (Tue, 07 Aug 2012) New Revision: 501 Modified: trunk/src/Makefile.OCaml trunk/src/RECENTNEWS trunk/src/mkProjectInfo.ml Log: * Fixed Makefile for cross-compiling towards Windows (updated to MinGW-w64) Modified: trunk/src/Makefile.OCaml =================================================================== --- trunk/src/Makefile.OCaml 2012-08-07 16:33:59 UTC (rev 500) +++ trunk/src/Makefile.OCaml 2012-08-07 16:57:51 UTC (rev 501) @@ -5,11 +5,6 @@ #################################################################### ### Try to automatically guess OS -ifeq (${OSCOMP},cross) # Cross-compilation under Linux - OSARCH=win32gnuc - PATH := /usr/i586-mingw32msvc/bin:$(PATH) -endif - ifeq (${OSCOMP},cygwingnuc) # Define this if compiling with Cygwin GNU C OSARCH=win32gnuc ETAGS=/bin/etags @@ -46,6 +41,11 @@ endif endif +ifeq (${OSCOMP},cross) # Cross-compilation under Linux + OSARCH=win32gnuc + EXEC_PREFIX=i686-w64-mingw32- +endif + # The OCaml lib dir is used by all versions # It is extracted from 'ocamlc -v' and Windows '\' separators are turned # to Unix '/' separators, and extraneous control-M's are deleted. @@ -364,11 +364,11 @@ endif ifeq ($(PROFILING), true) - OCAMLC=ocamlcp + OCAMLC=$(EXEC_PREFIX)ocamlcp else - OCAMLC=ocamlc + OCAMLC=$(EXEC_PREFIX)ocamlc endif -OCAMLOPT=ocamlopt +OCAMLOPT=$(EXEC_PREFIX)ocamlopt ifeq ($(NATIVE), true) ## Set up for native code compilation Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2012-08-07 16:33:59 UTC (rev 500) +++ trunk/src/RECENTNEWS 2012-08-07 16:57:51 UTC (rev 501) @@ -1,3 +1,8 @@ +CHANGES FROM VERSION 2.45.13 + +* Fixed Makefile for cross-compiling towards Windows (updated to MinGW-w64) + +------------------------------- CHANGES FROM VERSION 2.45.12 * fsmonitor.py: fixed busy wait under Windows Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2012-08-07 16:33:59 UTC (rev 500) +++ trunk/src/mkProjectInfo.ml 2012-08-07 16:57:51 UTC (rev 501) @@ -75,3 +75,4 @@ + From vouillon at seas.upenn.edu Tue Aug 7 14:44:28 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Tue, 7 Aug 2012 14:44:28 -0400 Subject: [Unison-hackers] [unison-svn] r502 - trunk/src Message-ID: <201208071844.q77IiTlA032395@yaws.seas.upenn.edu> Author: vouillon Date: 2012-08-07 14:44:28 -0400 (Tue, 07 Aug 2012) New Revision: 502 Modified: trunk/src/RECENTNEWS trunk/src/external.ml trunk/src/mkProjectInfo.ml Log: * Function External.readChannelTillEof now tail recursive (prevents a crash when the output of the diff program is too large) Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2012-08-07 16:57:51 UTC (rev 501) +++ trunk/src/RECENTNEWS 2012-08-07 18:44:28 UTC (rev 502) @@ -1,3 +1,9 @@ +CHANGES FROM VERSION 2.45.14 + +* Function External.readChannelTillEof now tail recursive + (prevents a crash when the output of the diff program is too large) + +------------------------------- CHANGES FROM VERSION 2.45.13 * Fixed Makefile for cross-compiling towards Windows (updated to MinGW-w64) Modified: trunk/src/external.ml =================================================================== --- trunk/src/external.ml 2012-08-07 16:57:51 UTC (rev 501) +++ trunk/src/external.ml 2012-08-07 18:44:28 UTC (rev 502) @@ -26,35 +26,30 @@ open Lwt let readChannelTillEof c = - let rec loop lines = - try let l = input_line c in - (* Util.msg "%s\n" l; *) - loop (l::lines) - with End_of_file -> lines in - String.concat "\n" (Safelist.rev (loop [])) + let lst = ref [] in + let rec loop () = + lst := input_line c :: !lst; + loop () + in + begin try loop () with End_of_file -> () end; + String.concat "\n" (Safelist.rev !lst) let readChannelTillEof_lwt c = let rec loop lines = - let lo = - try - Some(Lwt_unix.run (Lwt_unix.input_line c)) - with End_of_file -> None - in - match lo with - Some l -> loop (l :: lines) - | None -> lines + Lwt.try_bind + (fun () -> Lwt_unix.input_line c) + (fun l -> loop (l :: lines)) + (fun e -> if e = End_of_file then Lwt.return lines else Lwt.fail e) in - String.concat "\n" (Safelist.rev (loop [])) + String.concat "\n" (Safelist.rev (Lwt_unix.run (loop []))) let readChannelsTillEof l = let rec suckitdry lines c = - Lwt.catch - (fun() -> Lwt_unix.input_line c >>= (fun l -> return (Some l))) - (fun e -> match e with End_of_file -> return None | _ -> raise e) - >>= (fun lo -> - match lo with - None -> return lines - | Some l -> suckitdry (l :: lines) c) in + Lwt.try_bind + (fun () -> Lwt_unix.input_line c) + (fun l -> suckitdry (l :: lines) c) + (fun e -> match e with End_of_file -> Lwt.return lines | _ -> raise e) + in Lwt_util.map (fun c -> suckitdry [] c Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2012-08-07 16:57:51 UTC (rev 501) +++ trunk/src/mkProjectInfo.ml 2012-08-07 18:44:28 UTC (rev 502) @@ -76,3 +76,4 @@ + From vouillon at seas.upenn.edu Tue Aug 7 16:06:46 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Tue, 7 Aug 2012 16:06:46 -0400 Subject: [Unison-hackers] [unison-svn] r503 - trunk/src Message-ID: <201208072006.q77K6k7B002835@yaws.seas.upenn.edu> Author: vouillon Date: 2012-08-07 16:06:46 -0400 (Tue, 07 Aug 2012) New Revision: 503 Modified: trunk/src/RECENTNEWS trunk/src/mkProjectInfo.ml trunk/src/transfer.ml Log: * transfer.ml: updated debugging code; in particular, turns an assertion failure into a more friendly transient failure Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2012-08-07 18:44:28 UTC (rev 502) +++ trunk/src/RECENTNEWS 2012-08-07 20:06:46 UTC (rev 503) @@ -1,3 +1,9 @@ +CHANGES FROM VERSION 2.45.15 + +* transfer.ml: updated debugging code; in particular, turns an + assertion failure into a more friendly transient failure + +------------------------------- CHANGES FROM VERSION 2.45.14 * Function External.readChannelTillEof now tail recursive Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2012-08-07 18:44:28 UTC (rev 502) +++ trunk/src/mkProjectInfo.ml 2012-08-07 20:06:46 UTC (rev 503) @@ -77,3 +77,4 @@ + Modified: trunk/src/transfer.ml =================================================================== --- trunk/src/transfer.ml 2012-08-07 18:44:28 UTC (rev 502) +++ trunk/src/transfer.ml 2012-08-07 20:06:46 UTC (rev 503) @@ -423,9 +423,23 @@ blockIter infd addBlock blockSize (min blockCount (256*256*256)) in debugLog (fun() -> Util.msg "%d blocks\n" count); Trace.showTimer timer; - ({ blockSize = blockSize; blockCount = count; checksumSize = csSize; - weakChecksum = weakCs; strongChecksum = strongCs }, - blockSize) + let sigs = + { blockSize = blockSize; blockCount = count; checksumSize = csSize; + weakChecksum = weakCs; strongChecksum = strongCs } in + if + sigs.blockCount > Bigarray.Array1.dim sigs.weakChecksum || + sigs.blockCount * sigs.checksumSize > + Bigarray.Array1.dim sigs.strongChecksum + then + raise + (Util.Transient + (Format.sprintf + "Internal error during rsync transfer (preprocess), \ + please report: %d %d - %d %d" + sigs.blockCount (Bigarray.Array1.dim sigs.weakChecksum) + (sigs.blockCount * sigs.checksumSize) + (Bigarray.Array1.dim sigs.strongChecksum))); + (sigs, blockSize) (* Expected size of the [rsync_block_info] datastructure (in KiB). *) let memoryFootprint srcLength dstLength = @@ -522,12 +536,6 @@ let findEntry hashTable hashTableLength checksum : (int * Checksum.t) list = let i = (hash checksum) land (hashTableLength - 1) in - (*FIX: temporary debugging code... *) - if i < 0 || i >= Array.length hashTable then begin - Format.eprintf "index:%d checksum:%d len:%d/%d at ." - i checksum hashTableLength (Array.length hashTable); - assert false - end; hashTable.(i) let sigFilter hashTableLength signatures = @@ -621,6 +629,19 @@ (* Compress the file using the algorithm described in the header *) let rsyncCompress sigs infd srcLength showProgress transmit = debug (fun() -> Util.msg "compressing\n"); + if + sigs.blockCount > Bigarray.Array1.dim sigs.weakChecksum || + sigs.blockCount * sigs.checksumSize > + Bigarray.Array1.dim sigs.strongChecksum + then + raise + (Util.Transient + (Format.sprintf + "Internal error during rsync transfer (compression), \ + please report: %d %d - %d %d" + sigs.blockCount (Bigarray.Array1.dim sigs.weakChecksum) + (sigs.blockCount * sigs.checksumSize) + (Bigarray.Array1.dim sigs.strongChecksum))); let blockSize = sigs.blockSize in let comprBufSize = (2 * blockSize + 8191) land (-8192) in let comprBufSizeFS = Uutil.Filesize.ofInt comprBufSize in @@ -679,12 +700,14 @@ (*FIX: temporary debugging code... *) if pos + sigs.checksumSize > Bigarray.Array1.dim sigs.strongChecksum - then begin - Format.eprintf "k:%d/%d pos:%d csSize:%d dim:%d at ." - k sigs.blockCount pos sigs.checksumSize - (Bigarray.Array1.dim sigs.strongChecksum); - assert false - end; + then + raise + (Util.Transient + (Format.sprintf "Internal error during rsync transfer, \ + please report: \ + k:%d/%d pos:%d csSize:%d dim:%d" + k sigs.blockCount pos sigs.checksumSize + (Bigarray.Array1.dim sigs.strongChecksum))); fingerprintMatchRec sigs.strongChecksum pos fp sigs.checksumSize in From vouillon at seas.upenn.edu Thu Aug 9 10:06:21 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Thu, 9 Aug 2012 10:06:21 -0400 Subject: [Unison-hackers] [unison-svn] r504 - trunk/src Message-ID: <201208091406.q79E6MCT023883@yaws.seas.upenn.edu> Author: vouillon Date: 2012-08-09 10:06:21 -0400 (Thu, 09 Aug 2012) New Revision: 504 Added: trunk/src/fswatchold.ml trunk/src/fswatchold.mli Modified: trunk/src/.depend trunk/src/Makefile.OCaml trunk/src/RECENTNEWS trunk/src/mkProjectInfo.ml trunk/src/os.ml trunk/src/os.mli trunk/src/test.ml trunk/src/uigtk2.ml trunk/src/uimacbridge.ml trunk/src/uimacbridgenew.ml trunk/src/uitext.ml trunk/src/update.ml trunk/src/update.mli Log: * Bumped version number: incompatible protocol changes * Improvements to the file watching functionality: - retries paths with failures using an exponential backoff algorithm - the information returned by the file watchers are used independently for each replica; thus, when only one replica has changes, Unison will only rescan this replica - when available, used by the graphical UIs to speed up rescanning (can be disabled by setting the new 'watch' preference to false) Modified: trunk/src/.depend =================================================================== --- trunk/src/.depend 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/.depend 2012-08-09 14:06:21 UTC (rev 504) @@ -1,359 +1,371 @@ -abort.cmi: uutil.cmi -bytearray.cmi: -case.cmi: ubase/prefs.cmi -checksum.cmi: -clroot.cmi: +abort.cmi: uutil.cmi +bytearray.cmi: +case.cmi: ubase/prefs.cmi +checksum.cmi: +clroot.cmi: common.cmi: uutil.cmi props.cmi path.cmi osx.cmi os.cmi name.cmi fspath.cmi \ - fileinfo.cmi + fileinfo.cmi copy.cmi: uutil.cmi props.cmi path.cmi osx.cmi os.cmi lwt/lwt.cmi fspath.cmi \ - fileinfo.cmi common.cmi -external.cmi: lwt/lwt.cmi + fileinfo.cmi common.cmi +external.cmi: lwt/lwt.cmi fileinfo.cmi: system.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi \ - fspath.cmi + fspath.cmi files.cmi: uutil.cmi system.cmi props.cmi path.cmi lwt/lwt_util.cmi \ - lwt/lwt.cmi common.cmi -fileutil.cmi: -fingerprint.cmi: uutil.cmi path.cmi fspath.cmi + lwt/lwt.cmi common.cmi +fileutil.cmi: +fingerprint.cmi: uutil.cmi path.cmi fspath.cmi fpcache.cmi: system.cmi props.cmi path.cmi osx.cmi os.cmi fspath.cmi \ - fileinfo.cmi -fs.cmi: system/system_intf.cmo fspath.cmi -fspath.cmi: system.cmi path.cmi name.cmi -globals.cmi: ubase/prefs.cmi pred.cmi path.cmi lwt/lwt.cmi common.cmi -lock.cmi: system.cmi -name.cmi: -os.cmi: system.cmi props.cmi path.cmi name.cmi fspath.cmi fileinfo.cmi -osx.cmi: uutil.cmi ubase/prefs.cmi path.cmi fspath.cmi fingerprint.cmi -path.cmi: pred.cmi name.cmi -pred.cmi: -props.cmi: uutil.cmi ubase/prefs.cmi path.cmi osx.cmi fspath.cmi -recon.cmi: props.cmi path.cmi common.cmi + fileinfo.cmi +fs.cmi: system/system_intf.cmo fspath.cmi +fspath.cmi: system.cmi path.cmi name.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 +name.cmi: +os.cmi: uutil.cmi system.cmi props.cmi path.cmi name.cmi fspath.cmi \ + fileinfo.cmi +osx.cmi: uutil.cmi ubase/prefs.cmi path.cmi fspath.cmi fingerprint.cmi +path.cmi: pred.cmi name.cmi +pred.cmi: +props.cmi: uutil.cmi ubase/prefs.cmi path.cmi osx.cmi fspath.cmi +recon.cmi: props.cmi path.cmi common.cmi remote.cmi: ubase/prefs.cmi lwt/lwt.cmi fspath.cmi common.cmi clroot.cmi \ - bytearray.cmi -sortri.cmi: common.cmi -stasher.cmi: update.cmi ubase/prefs.cmi path.cmi os.cmi fspath.cmi -strings.cmi: -system.cmi: system/system_intf.cmo -terminal.cmi: lwt/lwt_unix.cmi -test.cmi: -transfer.cmi: uutil.cmi lwt/lwt.cmi bytearray.cmi -transport.cmi: uutil.cmi lwt/lwt.cmi common.cmi -tree.cmi: -ui.cmi: -uicommon.cmi: uutil.cmi ubase/prefs.cmi path.cmi lwt/lwt.cmi common.cmi -uigtk.cmi: uicommon.cmi -uigtk2.cmi: uicommon.cmi -uitext.cmi: uicommon.cmi -unicode.cmi: + bytearray.cmi +sortri.cmi: common.cmi +stasher.cmi: update.cmi ubase/prefs.cmi path.cmi os.cmi fspath.cmi +strings.cmi: +system.cmi: system/system_intf.cmo +terminal.cmi: lwt/lwt_unix.cmi +test.cmi: +transfer.cmi: uutil.cmi lwt/lwt.cmi bytearray.cmi +transport.cmi: uutil.cmi lwt/lwt.cmi common.cmi +tree.cmi: +ui.cmi: +uicommon.cmi: uutil.cmi ubase/prefs.cmi path.cmi lwt/lwt.cmi common.cmi +uigtk.cmi: uicommon.cmi +uigtk2.cmi: uicommon.cmi +uitext.cmi: uicommon.cmi +unicode.cmi: update.cmi: uutil.cmi tree.cmi props.cmi path.cmi osx.cmi os.cmi name.cmi \ - lwt/lwt.cmi fspath.cmi fileinfo.cmi common.cmi -uutil.cmi: -xferhint.cmi: ubase/prefs.cmi path.cmi os.cmi fspath.cmi -abort.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi abort.cmi -abort.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx ubase/prefs.cmx abort.cmi -bytearray.cmo: bytearray.cmi -bytearray.cmx: bytearray.cmi -case.cmo: ubase/util.cmi unicode.cmi ubase/prefs.cmi case.cmi -case.cmx: ubase/util.cmx unicode.cmx ubase/prefs.cmx case.cmi -checksum.cmo: checksum.cmi -checksum.cmx: checksum.cmi -clroot.cmo: ubase/util.cmi ubase/rx.cmi ubase/prefs.cmi clroot.cmi -clroot.cmx: ubase/util.cmx ubase/rx.cmx ubase/prefs.cmx clroot.cmi + ubase/myMap.cmi lwt/lwt.cmi fspath.cmi fileinfo.cmi common.cmi +uutil.cmi: +xferhint.cmi: ubase/prefs.cmi path.cmi os.cmi fspath.cmi +abort.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi abort.cmi +abort.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx ubase/prefs.cmx abort.cmi +bytearray.cmo: bytearray.cmi +bytearray.cmx: bytearray.cmi +case.cmo: ubase/util.cmi unicode.cmi ubase/prefs.cmi case.cmi +case.cmx: ubase/util.cmx unicode.cmx ubase/prefs.cmx case.cmi +checksum.cmo: checksum.cmi +checksum.cmx: checksum.cmi +clroot.cmo: ubase/util.cmi ubase/rx.cmi ubase/prefs.cmi clroot.cmi +clroot.cmx: ubase/util.cmx ubase/rx.cmx ubase/prefs.cmx clroot.cmi common.cmo: uutil.cmi ubase/util.cmi ubase/safelist.cmi props.cmi path.cmi \ - osx.cmi os.cmi name.cmi fspath.cmi fileinfo.cmi common.cmi + osx.cmi os.cmi name.cmi fspath.cmi fileinfo.cmi common.cmi common.cmx: uutil.cmx ubase/util.cmx ubase/safelist.cmx props.cmx path.cmx \ - osx.cmx os.cmx name.cmx fspath.cmx fileinfo.cmx common.cmi + osx.cmx os.cmx name.cmx fspath.cmx fileinfo.cmx common.cmi copy.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi transfer.cmi \ ubase/trace.cmi ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi \ path.cmi osx.cmi os.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi \ fspath.cmi fs.cmi fpcache.cmi fingerprint.cmi fileinfo.cmi external.cmi \ - common.cmi clroot.cmi bytearray.cmi abort.cmi copy.cmi + common.cmi clroot.cmi bytearray.cmi abort.cmi copy.cmi copy.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx transfer.cmx \ ubase/trace.cmx ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx \ path.cmx osx.cmx os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx \ fspath.cmx fs.cmx fpcache.cmx fingerprint.cmx fileinfo.cmx external.cmx \ - common.cmx clroot.cmx bytearray.cmx abort.cmx copy.cmi + common.cmx clroot.cmx bytearray.cmx abort.cmx copy.cmi external.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi lwt/lwt_util.cmi \ - lwt/lwt_unix.cmi lwt/lwt.cmi external.cmi + lwt/lwt_unix.cmi lwt/lwt.cmi external.cmi external.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx lwt/lwt_util.cmx \ - lwt/lwt_unix.cmx lwt/lwt.cmx external.cmi + 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 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 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 \ lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi \ fs.cmi fingerprint.cmi fileinfo.cmi external.cmi copy.cmi common.cmi \ - abort.cmi files.cmi + abort.cmi files.cmi files.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx ubase/trace.cmx \ system.cmx stasher.cmx ubase/safelist.cmx ubase/rx.cmx remote.cmx \ props.cmx ubase/prefs.cmx path.cmx osx.cmx os.cmx name.cmx \ lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx \ fs.cmx fingerprint.cmx fileinfo.cmx external.cmx copy.cmx common.cmx \ - abort.cmx files.cmi -fileutil.cmo: fileutil.cmi -fileutil.cmx: fileutil.cmi -fingerprint.cmo: uutil.cmi ubase/util.cmi fspath.cmi fs.cmi fingerprint.cmi -fingerprint.cmx: uutil.cmx ubase/util.cmx fspath.cmx fs.cmx fingerprint.cmi + abort.cmx files.cmi +fileutil.cmo: fileutil.cmi +fileutil.cmx: fileutil.cmi +fingerprint.cmo: uutil.cmi ubase/util.cmi path.cmi fspath.cmi fs.cmi \ + fingerprint.cmi +fingerprint.cmx: uutil.cmx ubase/util.cmx path.cmx fspath.cmx fs.cmx \ + fingerprint.cmi fpcache.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi system.cmi \ - ubase/safelist.cmi props.cmi path.cmi osx.cmi os.cmi fileinfo.cmi \ - fpcache.cmi + ubase/safelist.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi os.cmi \ + fspath.cmi fileinfo.cmi fpcache.cmi fpcache.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx system.cmx \ - ubase/safelist.cmx props.cmx path.cmx osx.cmx os.cmx fileinfo.cmx \ - fpcache.cmi -fs.cmo: fspath.cmi fs.cmi -fs.cmx: fspath.cmx fs.cmi + ubase/safelist.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx os.cmx \ + fspath.cmx fileinfo.cmx fpcache.cmi +fs.cmo: fspath.cmi fs.cmi +fs.cmx: fspath.cmx fs.cmi fspath.cmo: uutil.cmi ubase/util.cmi system.cmi ubase/rx.cmi path.cmi \ - name.cmi fileutil.cmi fspath.cmi + 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 + name.cmx fileutil.cmx fspath.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 +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.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 + 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 -linkgtk2.cmx: uigtk2.cmx main.cmx -linktext.cmo: uitext.cmi main.cmo -linktext.cmx: uitext.cmx main.cmx -lock.cmo: ubase/util.cmi system.cmi lock.cmi -lock.cmx: ubase/util.cmx system.cmx lock.cmi + lwt/lwt_unix.cmx lwt/lwt.cmx common.cmx clroot.cmx globals.cmi +linkgtk.cmo: uigtk.cmi main.cmo +linkgtk.cmx: uigtk.cmx main.cmx +linkgtk2.cmo: uigtk2.cmi main.cmo +linkgtk2.cmx: uigtk2.cmx main.cmx +linktext.cmo: uitext.cmi main.cmo +linktext.cmx: uitext.cmx main.cmx +lock.cmo: ubase/util.cmi system.cmi lock.cmi +lock.cmx: ubase/util.cmx system.cmx lock.cmi main.cmo: uutil.cmi ubase/util.cmi uitext.cmi uicommon.cmi strings.cmi \ - ubase/safelist.cmi remote.cmi ubase/prefs.cmi os.cmi + ubase/safelist.cmi remote.cmi ubase/prefs.cmi os.cmi main.cmx: uutil.cmx ubase/util.cmx uitext.cmx uicommon.cmx strings.cmx \ - ubase/safelist.cmx remote.cmx ubase/prefs.cmx os.cmx -mkProjectInfo.cmo: -mkProjectInfo.cmx: -name.cmo: ubase/util.cmi ubase/rx.cmi case.cmi name.cmi -name.cmx: ubase/util.cmx ubase/rx.cmx case.cmx name.cmi -os.cmo: uutil.cmi ubase/util.cmi system.cmi ubase/safelist.cmi props.cmi \ - ubase/prefs.cmi path.cmi osx.cmi name.cmi fspath.cmi fs.cmi \ - fingerprint.cmi fileinfo.cmi os.cmi -os.cmx: uutil.cmx ubase/util.cmx system.cmx ubase/safelist.cmx props.cmx \ - ubase/prefs.cmx path.cmx osx.cmx name.cmx fspath.cmx fs.cmx \ - fingerprint.cmx fileinfo.cmx os.cmi + ubase/safelist.cmx remote.cmx ubase/prefs.cmx os.cmx +mkProjectInfo.cmo: +mkProjectInfo.cmx: +name.cmo: ubase/util.cmi ubase/rx.cmi case.cmi name.cmi +name.cmx: ubase/util.cmx ubase/rx.cmx case.cmx name.cmi +os.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi system.cmi \ + ubase/safelist.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi name.cmi \ + fspath.cmi fs.cmi fingerprint.cmi fileinfo.cmi os.cmi +os.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx system.cmx \ + ubase/safelist.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx name.cmx \ + fspath.cmx fs.cmx fingerprint.cmx fileinfo.cmx os.cmi osx.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi system.cmi \ ubase/safelist.cmi ubase/prefs.cmi path.cmi name.cmi fspath.cmi fs.cmi \ - fingerprint.cmi osx.cmi + fingerprint.cmi osx.cmi osx.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx system.cmx \ ubase/safelist.cmx ubase/prefs.cmx path.cmx name.cmx fspath.cmx fs.cmx \ - fingerprint.cmx osx.cmi + fingerprint.cmx osx.cmi path.cmo: ubase/util.cmi ubase/safelist.cmi ubase/rx.cmi pred.cmi name.cmi \ - fileutil.cmi case.cmi path.cmi + fileutil.cmi case.cmi path.cmi path.cmx: ubase/util.cmx ubase/safelist.cmx ubase/rx.cmx pred.cmx name.cmx \ - fileutil.cmx case.cmx path.cmi -pixmaps.cmo: -pixmaps.cmx: + fileutil.cmx case.cmx path.cmi +pixmaps.cmo: +pixmaps.cmx: pred.cmo: ubase/util.cmi ubase/safelist.cmi ubase/rx.cmi ubase/prefs.cmi \ - case.cmi pred.cmi + case.cmi pred.cmi pred.cmx: ubase/util.cmx ubase/safelist.cmx ubase/rx.cmx ubase/prefs.cmx \ - case.cmx pred.cmi + case.cmx pred.cmi props.cmo: uutil.cmi ubase/util.cmi ubase/prefs.cmi path.cmi osx.cmi \ - lwt/lwt_unix.cmi fspath.cmi fs.cmi external.cmi props.cmi + lwt/lwt_unix.cmi fspath.cmi fs.cmi external.cmi props.cmi props.cmx: uutil.cmx ubase/util.cmx ubase/prefs.cmx path.cmx osx.cmx \ - lwt/lwt_unix.cmx fspath.cmx fs.cmx external.cmx props.cmi + lwt/lwt_unix.cmx fspath.cmx fs.cmx external.cmx props.cmi recon.cmo: ubase/util.cmi update.cmi tree.cmi ubase/trace.cmi sortri.cmi \ ubase/safelist.cmi props.cmi ubase/prefs.cmi pred.cmi path.cmi name.cmi \ - globals.cmi fileinfo.cmi common.cmi recon.cmi + globals.cmi fileinfo.cmi common.cmi recon.cmi recon.cmx: ubase/util.cmx update.cmx tree.cmx ubase/trace.cmx sortri.cmx \ ubase/safelist.cmx props.cmx ubase/prefs.cmx pred.cmx path.cmx name.cmx \ - globals.cmx fileinfo.cmx common.cmx recon.cmi + globals.cmx fileinfo.cmx common.cmx recon.cmi remote.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi terminal.cmi system.cmi \ ubase/safelist.cmi ubase/prefs.cmi os.cmi lwt/lwt_util.cmi \ lwt/lwt_unix.cmi lwt/lwt.cmi fspath.cmi fs.cmi common.cmi clroot.cmi \ - case.cmi bytearray.cmi remote.cmi + case.cmi bytearray.cmi remote.cmi remote.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx terminal.cmx system.cmx \ ubase/safelist.cmx ubase/prefs.cmx os.cmx lwt/lwt_util.cmx \ lwt/lwt_unix.cmx lwt/lwt.cmx fspath.cmx fs.cmx common.cmx clroot.cmx \ - case.cmx bytearray.cmx remote.cmi + case.cmx bytearray.cmx remote.cmi sortri.cmo: ubase/util.cmi ubase/safelist.cmi ubase/prefs.cmi pred.cmi \ - path.cmi common.cmi sortri.cmi + path.cmi common.cmi sortri.cmi sortri.cmx: ubase/util.cmx ubase/safelist.cmx ubase/prefs.cmx pred.cmx \ - path.cmx common.cmx sortri.cmi + path.cmx common.cmx sortri.cmi stasher.cmo: xferhint.cmi ubase/util.cmi update.cmi system.cmi \ ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi pred.cmi path.cmi \ osx.cmi os.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi \ - fingerprint.cmi fileutil.cmi fileinfo.cmi copy.cmi common.cmi stasher.cmi + fingerprint.cmi fileutil.cmi fileinfo.cmi copy.cmi common.cmi stasher.cmi stasher.cmx: xferhint.cmx ubase/util.cmx update.cmx system.cmx \ ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx pred.cmx path.cmx \ osx.cmx os.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx \ - fingerprint.cmx fileutil.cmx fileinfo.cmx copy.cmx common.cmx stasher.cmi -strings.cmo: strings.cmi -strings.cmx: strings.cmi -system.cmo: system.cmi -system.cmx: system.cmi + fingerprint.cmx fileutil.cmx fileinfo.cmx copy.cmx common.cmx stasher.cmi +strings.cmo: strings.cmi +strings.cmx: strings.cmi +system.cmo: system.cmi +system.cmx: system.cmi terminal.cmo: system.cmi ubase/rx.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \ - terminal.cmi + terminal.cmi terminal.cmx: system.cmx ubase/rx.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \ - terminal.cmi + terminal.cmi test.cmo: uutil.cmi ubase/util.cmi update.cmi uicommon.cmi transport.cmi \ ubase/trace.cmi stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi \ ubase/prefs.cmi path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi \ lwt/lwt.cmi globals.cmi fspath.cmi fs.cmi fingerprint.cmi common.cmi \ - test.cmi + test.cmi test.cmx: uutil.cmx ubase/util.cmx update.cmx uicommon.cmx transport.cmx \ ubase/trace.cmx stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx \ ubase/prefs.cmx path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx \ lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx fingerprint.cmx common.cmx \ - test.cmi + test.cmi transfer.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi ubase/safelist.cmi \ - lwt/lwt.cmi checksum.cmi bytearray.cmi transfer.cmi + lwt/lwt.cmi checksum.cmi bytearray.cmi transfer.cmi transfer.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx ubase/safelist.cmx \ - lwt/lwt.cmx checksum.cmx bytearray.cmx transfer.cmi + lwt/lwt.cmx checksum.cmx bytearray.cmx transfer.cmi transport.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi remote.cmi props.cmi \ ubase/prefs.cmi path.cmi osx.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi \ - files.cmi common.cmi abort.cmi transport.cmi + files.cmi common.cmi abort.cmi transport.cmi transport.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx remote.cmx props.cmx \ ubase/prefs.cmx path.cmx osx.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx \ - files.cmx common.cmx abort.cmx transport.cmi -tree.cmo: ubase/safelist.cmi tree.cmi -tree.cmx: ubase/safelist.cmx tree.cmi + files.cmx common.cmx abort.cmx transport.cmi +tree.cmo: ubase/safelist.cmi tree.cmi +tree.cmx: ubase/safelist.cmx tree.cmi uicommon.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi \ ubase/trace.cmi system.cmi stasher.cmi ubase/safelist.cmi remote.cmi \ recon.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi os.cmi name.cmi \ lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi files.cmi \ - fileinfo.cmi common.cmi clroot.cmi case.cmi uicommon.cmi + fileinfo.cmi common.cmi clroot.cmi case.cmi uicommon.cmi uicommon.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx \ ubase/trace.cmx system.cmx stasher.cmx ubase/safelist.cmx remote.cmx \ recon.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx os.cmx name.cmx \ lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx files.cmx \ - fileinfo.cmx common.cmx clroot.cmx case.cmx uicommon.cmi + fileinfo.cmx common.cmx clroot.cmx case.cmx uicommon.cmi uigtk.cmo: uutil.cmi ubase/util.cmi update.cmi uitext.cmi uicommon.cmi \ transport.cmi ubase/trace.cmi system.cmi strings.cmi sortri.cmi \ ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi pixmaps.cmo \ path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi \ - files.cmi common.cmi clroot.cmi uigtk.cmi + files.cmi common.cmi clroot.cmi uigtk.cmi uigtk.cmx: uutil.cmx ubase/util.cmx update.cmx uitext.cmx uicommon.cmx \ transport.cmx ubase/trace.cmx system.cmx strings.cmx sortri.cmx \ ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx pixmaps.cmx \ path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx \ - files.cmx common.cmx clroot.cmx uigtk.cmi + files.cmx common.cmx clroot.cmx uigtk.cmi uigtk2.cmo: uutil.cmi ubase/util.cmi update.cmi unicode.cmi uitext.cmi \ uicommon.cmi transport.cmi ubase/trace.cmi system.cmi strings.cmi \ sortri.cmi ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi \ pixmaps.cmo path.cmi os.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \ - globals.cmi files.cmi common.cmi clroot.cmi case.cmi uigtk2.cmi + globals.cmi files.cmi common.cmi clroot.cmi case.cmi uigtk2.cmi uigtk2.cmx: uutil.cmx ubase/util.cmx update.cmx unicode.cmx uitext.cmx \ uicommon.cmx transport.cmx ubase/trace.cmx system.cmx strings.cmx \ sortri.cmx ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx \ pixmaps.cmx path.cmx os.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \ - globals.cmx files.cmx common.cmx clroot.cmx case.cmx uigtk2.cmi + globals.cmx files.cmx common.cmx clroot.cmx case.cmx uigtk2.cmi uimacbridge.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi \ uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi system.cmi \ stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi ubase/prefs.cmi \ path.cmi os.cmi main.cmo lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \ - globals.cmi fspath.cmi files.cmi common.cmi clroot.cmi + globals.cmi fspath.cmi files.cmi common.cmi clroot.cmi uimacbridge.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx \ uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx system.cmx \ stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx ubase/prefs.cmx \ path.cmx os.cmx main.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \ - globals.cmx fspath.cmx files.cmx common.cmx clroot.cmx + globals.cmx fspath.cmx files.cmx common.cmx clroot.cmx uimacbridgenew.cmo: xferhint.cmi uutil.cmi ubase/util.cmi update.cmi \ unicode.cmi uicommon.cmi transport.cmi ubase/trace.cmi terminal.cmi \ system.cmi stasher.cmi ubase/safelist.cmi remote.cmi recon.cmi \ ubase/prefs.cmi path.cmi os.cmi main.cmo lwt/lwt_util.cmi \ lwt/lwt_unix.cmi lwt/lwt.cmi globals.cmi fspath.cmi files.cmi common.cmi \ - clroot.cmi + clroot.cmi uimacbridgenew.cmx: xferhint.cmx uutil.cmx ubase/util.cmx update.cmx \ unicode.cmx uicommon.cmx transport.cmx ubase/trace.cmx terminal.cmx \ system.cmx stasher.cmx ubase/safelist.cmx remote.cmx recon.cmx \ ubase/prefs.cmx path.cmx os.cmx main.cmx lwt/lwt_util.cmx \ lwt/lwt_unix.cmx lwt/lwt.cmx globals.cmx fspath.cmx files.cmx common.cmx \ - clroot.cmx + clroot.cmx uitext.cmo: uutil.cmi ubase/util.cmi update.cmi uicommon.cmi transport.cmi \ ubase/trace.cmi system.cmi ubase/safelist.cmi remote.cmi recon.cmi \ ubase/prefs.cmi path.cmi lwt/lwt_util.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \ - globals.cmi common.cmi uitext.cmi + globals.cmi fswatchold.cmi common.cmi uitext.cmi uitext.cmx: uutil.cmx ubase/util.cmx update.cmx uicommon.cmx transport.cmx \ ubase/trace.cmx system.cmx ubase/safelist.cmx remote.cmx recon.cmx \ ubase/prefs.cmx path.cmx lwt/lwt_util.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \ - globals.cmx common.cmx uitext.cmi -unicode.cmo: unicode_tables.cmo unicode.cmi -unicode.cmx: unicode_tables.cmx unicode.cmi -unicode_tables.cmo: -unicode_tables.cmx: + globals.cmx fswatchold.cmx common.cmx uitext.cmi +unicode.cmo: unicode_tables.cmo unicode.cmi +unicode.cmx: unicode_tables.cmx unicode.cmi +unicode_tables.cmo: +unicode_tables.cmx: update.cmo: xferhint.cmi uutil.cmi ubase/util.cmi tree.cmi ubase/trace.cmi \ 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 fspath.cmi fpcache.cmi \ - fingerprint.cmi fileinfo.cmi common.cmi case.cmi update.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 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 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 + 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 xferhint.cmo: ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi path.cmi os.cmi \ - fspath.cmi xferhint.cmi + fspath.cmi xferhint.cmi xferhint.cmx: ubase/util.cmx ubase/trace.cmx ubase/prefs.cmx path.cmx os.cmx \ - fspath.cmx xferhint.cmi -lwt/lwt.cmo: lwt/lwt.cmi -lwt/lwt.cmx: lwt/lwt.cmi -lwt/lwt_unix.cmo: lwt/lwt_unix.cmi -lwt/lwt_unix.cmx: lwt/lwt_unix.cmi -lwt/lwt_util.cmo: lwt/lwt.cmi lwt/lwt_util.cmi -lwt/lwt_util.cmx: lwt/lwt.cmx lwt/lwt_util.cmi -lwt/pqueue.cmo: lwt/pqueue.cmi -lwt/pqueue.cmx: lwt/pqueue.cmi -system/system_generic.cmo: -system/system_generic.cmx: -system/system_intf.cmo: -system/system_intf.cmx: -system/system_win.cmo: unicode.cmi system/system_generic.cmo ubase/rx.cmi -system/system_win.cmx: unicode.cmx system/system_generic.cmx ubase/rx.cmx -ubase/myMap.cmo: ubase/myMap.cmi -ubase/myMap.cmx: ubase/myMap.cmi + fspath.cmx xferhint.cmi +lwt/lwt.cmo: lwt/lwt.cmi +lwt/lwt.cmx: lwt/lwt.cmi +lwt/lwt_unix.cmo: lwt/lwt_unix.cmi +lwt/lwt_unix.cmx: lwt/lwt_unix.cmi +lwt/lwt_util.cmo: lwt/lwt.cmi lwt/lwt_util.cmi +lwt/lwt_util.cmx: lwt/lwt.cmx lwt/lwt_util.cmi +lwt/pqueue.cmo: lwt/pqueue.cmi +lwt/pqueue.cmx: lwt/pqueue.cmi +system/system_generic.cmo: +system/system_generic.cmx: +system/system_intf.cmo: +system/system_intf.cmx: +system/system_win.cmo: unicode.cmi system/system_generic.cmo ubase/rx.cmi +system/system_win.cmx: unicode.cmx system/system_generic.cmx ubase/rx.cmx +ubase/myMap.cmo: ubase/myMap.cmi +ubase/myMap.cmx: ubase/myMap.cmi ubase/prefs.cmo: ubase/util.cmi ubase/uarg.cmi system.cmi ubase/safelist.cmi \ - ubase/prefs.cmi + ubase/prefs.cmi ubase/prefs.cmx: ubase/util.cmx ubase/uarg.cmx system.cmx ubase/safelist.cmx \ - ubase/prefs.cmi -ubase/proplist.cmo: ubase/util.cmi ubase/proplist.cmi -ubase/proplist.cmx: ubase/util.cmx ubase/proplist.cmi -ubase/rx.cmo: ubase/rx.cmi -ubase/rx.cmx: ubase/rx.cmi -ubase/safelist.cmo: ubase/safelist.cmi -ubase/safelist.cmx: ubase/safelist.cmi + 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 +ubase/rx.cmx: ubase/rx.cmi +ubase/safelist.cmo: ubase/safelist.cmi +ubase/safelist.cmx: ubase/safelist.cmi ubase/trace.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi ubase/prefs.cmi \ - ubase/trace.cmi + ubase/trace.cmi ubase/trace.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx ubase/prefs.cmx \ - ubase/trace.cmi -ubase/uarg.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi ubase/uarg.cmi -ubase/uarg.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx ubase/uarg.cmi -ubase/uprintf.cmo: ubase/uprintf.cmi -ubase/uprintf.cmx: ubase/uprintf.cmi + ubase/trace.cmi +ubase/uarg.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi ubase/uarg.cmi +ubase/uarg.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx ubase/uarg.cmi +ubase/uprintf.cmo: ubase/uprintf.cmi +ubase/uprintf.cmx: ubase/uprintf.cmi ubase/util.cmo: ubase/uprintf.cmi system.cmi ubase/safelist.cmi \ - ubase/util.cmi + ubase/util.cmi ubase/util.cmx: ubase/uprintf.cmx system.cmx ubase/safelist.cmx \ - ubase/util.cmi -lwt/lwt.cmi: -lwt/lwt_unix.cmi: lwt/lwt.cmi -lwt/lwt_util.cmi: lwt/lwt.cmi -lwt/pqueue.cmi: -ubase/myMap.cmi: -ubase/prefs.cmi: ubase/util.cmi system.cmi -ubase/proplist.cmi: -ubase/rx.cmi: -ubase/safelist.cmi: -ubase/trace.cmi: ubase/prefs.cmi -ubase/uarg.cmi: -ubase/uprintf.cmi: -ubase/util.cmi: system.cmi -lwt/example/editor.cmo: lwt/lwt_unix.cmi -lwt/example/editor.cmx: lwt/lwt_unix.cmx -lwt/example/relay.cmo: lwt/lwt_unix.cmi lwt/lwt.cmi -lwt/example/relay.cmx: lwt/lwt_unix.cmx lwt/lwt.cmx -lwt/generic/lwt_unix_impl.cmo: lwt/pqueue.cmi lwt/lwt.cmi -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 -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 + ubase/util.cmi +lwt/lwt.cmi: +lwt/lwt_unix.cmi: lwt/lwt.cmi +lwt/lwt_util.cmi: lwt/lwt.cmi +lwt/pqueue.cmi: +ubase/myMap.cmi: +ubase/prefs.cmi: ubase/util.cmi system.cmi +ubase/proplist.cmi: +ubase/rx.cmi: +ubase/safelist.cmi: +ubase/trace.cmi: ubase/prefs.cmi +ubase/uarg.cmi: +ubase/uprintf.cmi: +ubase/util.cmi: system.cmi +lwt/example/editor.cmo: lwt/lwt_unix.cmi +lwt/example/editor.cmx: lwt/lwt_unix.cmx +lwt/example/relay.cmo: lwt/lwt_unix.cmi lwt/lwt.cmi +lwt/example/relay.cmx: lwt/lwt_unix.cmx lwt/lwt.cmx +lwt/generic/lwt_unix_impl.cmo: lwt/pqueue.cmi lwt/lwt.cmi +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 +system/generic/system_impl.cmo: system/system_generic.cmo +system/generic/system_impl.cmx: system/system_generic.cmx +system/win/system_impl.cmo: system/system_win.cmo system/system_generic.cmo +system/win/system_impl.cmx: system/system_win.cmx system/system_generic.cmx Modified: trunk/src/Makefile.OCaml =================================================================== --- trunk/src/Makefile.OCaml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/Makefile.OCaml 2012-08-09 14:06:21 UTC (rev 504) @@ -226,7 +226,7 @@ abort.cmo osx.cmo external.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 \ + transfer.cmo xferhint.cmo remote.cmo globals.cmo fswatchold.cmo \ fpcache.cmo update.cmo copy.cmo stasher.cmo \ files.cmo sortri.cmo recon.cmo transport.cmo \ strings.cmo uicommon.cmo uitext.cmo test.cmo Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/RECENTNEWS 2012-08-09 14:06:21 UTC (rev 504) @@ -1,3 +1,15 @@ +CHANGES FROM VERSION 2.46.-1 + +* Bumped version number: incompatible protocol changes +* Improvements to the file watching functionality: + - retries paths with failures using an exponential backoff algorithm + - the information returned by the file watchers are used + independently for each replica; thus, when only one replica has + changes, Unison will only rescan this replica + - when available, used by the graphical UIs to speed up rescanning + (can be disabled by setting the new 'watch' preference to false) + +------------------------------- CHANGES FROM VERSION 2.45.15 * transfer.ml: updated debugging code; in particular, turns an Added: trunk/src/fswatchold.ml =================================================================== --- trunk/src/fswatchold.ml (rev 0) +++ trunk/src/fswatchold.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -0,0 +1,167 @@ +(* Unison file synchronizer: src/fswatcherold.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 . +*) + +(* FIX: we should check that the child process has not died and + restart it if so... *) + +(* 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 + +let watcherTemp archHash n = Os.fileInUnisonDir (n ^ archHash) + +let watchercmd archHash root = + let fsmonfile = + Filename.concat (Filename.dirname Sys.executable_name) "fsmonitor.py" in + if not (Sys.file_exists fsmonfile) then + None + else begin + (* FIX: is the quoting of --follow parameters going to work on Win32? + (2/2012: tried adding Uutil.quotes -- maybe this is OK now?) *) + (* FIX -- need to find the program using watcherosx preference *) + let changefile = watcherTemp archHash "changes" in + let statefile = watcherTemp archHash "state" in + let paths = Safelist.map Path.toString (Prefs.read Globals.paths) in + let followpaths = Pred.extern Path.followPred in + let follow = Safelist.map + (fun s -> "--follow '" ^ Uutil.quotes s ^ "'") + followpaths in + (* BCP (per Josh Berdine, 5/2012): changed startup command from this... + let cmd = Printf.sprintf "fsmonitor.py %s --outfile %s --statefile %s %s %s\n" + ... to this: *) + let cmd = Printf.sprintf "python \"%s\" \"%s\" --outfile \"%s\" --statefile \"%s\" %s %s\n" + fsmonfile + root + (System.fspathToPrintString changefile) + (System.fspathToPrintString statefile) + (String.concat " " follow) + (String.concat " " paths) in + debug (fun() -> Util.msg "watchercmd = %s\n" cmd); + Some (changefile,cmd) + end + +module StringSet= Set.Make (String) +module RootMap = Map.Make (String) +type watcherinfo = {file: System.fspath; + mutable ch:Pervasives.in_channel option; + chars: Buffer.t; + mutable lines: string list} +let watchers : watcherinfo RootMap.t ref = ref RootMap.empty + +let trim_duplicates l = + let rec loop l = match l with + [] -> l + | [s] -> l + | s1::s2::rest -> + if Util.startswith s1 s2 || Util.startswith s2 s1 then + loop (s2::rest) + else + s1 :: (loop (s2::rest)) in + loop (Safelist.sort String.compare l) + +let readAvailableLinesFromWatcher wi = + let ch = match wi.ch with Some(c) -> c | None -> assert false in + let rec loop () = + match try Some(input_char ch) with End_of_file -> None with + None -> + () + | Some(c) -> + if c = '\n' then begin + wi.lines <- Buffer.contents wi.chars :: wi.lines; + Buffer.clear wi.chars; + loop () + end else begin + Buffer.add_char wi.chars c; + loop () + end in + loop () + +let readChanges wi = + if wi.ch = None then + (* Watcher channel not built yet *) + if System.file_exists wi.file then begin + (* Build it and go *) + let c = System.open_in_bin wi.file in + wi.ch <- Some c; + readAvailableLinesFromWatcher wi; + end else begin + (* Wait for change file to be built *) + debug (fun() -> Util.msg + "Waiting for change file %s\n" + (System.fspathToPrintString wi.file)) + end + else + (* Watcher running and channel built: go ahead and read *) + readAvailableLinesFromWatcher wi + +let getChanges archHash = + let wi = RootMap.find archHash !watchers in + readChanges wi; + let res = wi.lines in + wi.lines <- []; + List.map Path.fromString (trim_duplicates res) + +let start archHash fspath = + if not (Prefs.read useWatcher) then + false + else if not (RootMap.mem archHash !watchers) then begin + (* Watcher process not running *) + match watchercmd archHash (Fspath.toString fspath) with + Some (changefile,cmd) -> + debug (fun() -> Util.msg + "Starting watcher on fspath %s\n" + (Fspath.toDebugString fspath)); + let _ = System.open_process_out cmd in + let wi = {file = changefile; ch = None; + lines = []; chars = Buffer.create 80} in + watchers := RootMap.add archHash wi !watchers; + true + | None -> + false + end else begin + (* If already running, discard all pending changes *) + ignore (getChanges archHash); + true + end + +let wait archHash = + 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 + let rec loop () = + readChanges wi; + if wi.lines = [] then begin + debug (fun() -> Util.msg "Sleeping for %d seconds...\n" watchinterval); + Lwt.bind (Lwt_unix.sleep (float watchinterval)) (fun () -> + loop ()) + end else + Lwt.return () + in + loop () + end Added: trunk/src/fswatchold.mli =================================================================== --- trunk/src/fswatchold.mli (rev 0) +++ trunk/src/fswatchold.mli 2012-08-09 14:06:21 UTC (rev 504) @@ -0,0 +1,4 @@ + +val start : string -> Fspath.t -> bool +val getChanges : string -> Path.t list +val wait : string -> unit Lwt.t Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/mkProjectInfo.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -5,8 +5,8 @@ let projectName = "unison" let majorVersion = 2 -let minorVersion = 45 -let pointVersionOrigin = 487 (* Revision that corresponds to point version 0 *) +let minorVersion = 46 +let pointVersionOrigin = 504 (* Revision that corresponds to point version 0 *) (* Documentation: This is a program to construct a version of the form Major.Minor.Point, @@ -78,3 +78,4 @@ + Modified: trunk/src/os.ml =================================================================== --- trunk/src/os.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/os.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -50,6 +50,10 @@ if s = "" then tempFileSuffixFixed else "." ^ s ^ tempFileSuffixFixed +let isTempFile file = + Util.endswith file tempFileSuffixFixed && + Util.startswith file tempFilePrefix + (*****************************************************************************) (* QUERYING THE FILESYSTEM *) (*****************************************************************************) @@ -124,10 +128,7 @@ (* removeBackupIfUnwanted fspath newPath; *) (* false *) (* end *) - else if - Util.endswith file tempFileSuffixFixed && - Util.startswith file tempFilePrefix - then begin + else if isTempFile file then begin if Util.endswith file !tempFileSuffix then begin let p = Path.child path filename in let i = Fileinfo.get false fspath p in Modified: trunk/src/os.mli =================================================================== --- trunk/src/os.mli 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/os.mli 2012-08-09 14:06:21 UTC (rev 504) @@ -5,6 +5,7 @@ val tempPath : ?fresh:bool -> Fspath.t -> Path.local -> Path.local val tempFilePrefix : string +val isTempFile : string -> bool val includeInTempNames : string -> unit val exists : Fspath.t -> Path.local -> bool Modified: trunk/src/test.ml =================================================================== --- trunk/src/test.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/test.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -214,7 +214,7 @@ let sync ?(verbose=false) () = let (reconItemList, _, _) = - Recon.reconcileAll (Update.findUpdates()) in + Recon.reconcileAll (Update.findUpdates None) in if verbose then begin Util.msg "Sync result:\n"; displayRis reconItemList Modified: trunk/src/uigtk2.ml =================================================================== --- trunk/src/uigtk2.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/uigtk2.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -125,6 +125,7 @@ mutable bytesToTransfer : Uutil.Filesize.t; mutable whatHappened : (Util.confirmation * string option) option} let theState = ref [||] +let unsynchronizedPaths = ref None module IntSet = Set.Make (struct type t = int let compare = compare end) @@ -3368,7 +3369,7 @@ let findUpdates () = let t = Trace.startTimer "Checking for updates" in Trace.status "Looking for changes"; - let updates = Update.findUpdates () in + let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in Trace.showTimer t; updates in let reconcile updates = @@ -3396,6 +3397,8 @@ bytesToTransfer = Uutil.Filesize.zero; whatHappened = None }) reconItemList); + unsynchronizedPaths := + Some (List.map (fun ri -> ri.path1) reconItemList, []); current := IntSet.empty; displayMain(); progressBarPulse := false; sync_action := None; displayGlobalProgress 0.; @@ -3645,6 +3648,10 @@ if skippedCount = 0 then [] else [Printf.sprintf "%d skipped" skippedCount] in + unsynchronizedPaths := + Some (List.map (fun (si, _, _) -> si.ri.path1) + (failureList @ partialList @ skippedList), + []); Trace.status (Printf.sprintf "Synchronization complete %s" (String.concat ", " (failures @ partials @ skipped))); @@ -3891,6 +3898,7 @@ let loadProfile p reload = debug (fun()-> Util.msg "Loading profile %s..." p); Trace.status "Loading profile"; + unsynchronizedPaths := None; Uicommon.initPrefs p (fun () -> if not reload then displayWaitMessage ()) getFirstRoot getSecondRoot termInteract; @@ -4123,9 +4131,13 @@ let confirmBigDeletes = Prefs.read Globals.confirmBigDeletes in Prefs.set Globals.paths failedpaths; Prefs.set Globals.confirmBigDeletes false; + (* Modifying global paths does not play well with filesystem + monitoring, so we disable it. *) + unsynchronizedPaths := None; detectCmd(); Prefs.set Globals.paths paths; - Prefs.set Globals.confirmBigDeletes confirmBigDeletes) + Prefs.set Globals.confirmBigDeletes confirmBigDeletes; + unsynchronizedPaths := None) "Re_check Unsynchronized Items"); ignore (fileMenu#add_separator ()); Modified: trunk/src/uimacbridge.ml =================================================================== --- trunk/src/uimacbridge.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/uimacbridge.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -17,6 +17,7 @@ mutable whatHappened : Util.confirmation option; mutable statusMessage : string option };; let theState = ref [| |];; +let unsynchronizedPaths = ref None;; let unisonDirectory() = System.fspathToPrintString Os.unisonDir ;; @@ -126,6 +127,7 @@ (* Load the profile and command-line arguments *) (* Restore prefs to their default values, if necessary *) if not !firstTime then Prefs.resetToDefaults(); + unsynchronizedPaths := None; (* Tell the preferences module the name of the profile *) Prefs.profileName := Some(profileName); @@ -232,7 +234,7 @@ let t = Trace.startTimer "Checking for updates" in let findUpdates () = Trace.status "Looking for changes"; - let updates = Update.findUpdates () in + let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in Trace.showTimer t; updates in let reconcile updates = Recon.reconcileAll updates in @@ -252,6 +254,8 @@ whatHappened = None; statusMessage = None }) reconItemList in theState := Array.of_list stateItemList; + unsynchronizedPaths := + Some (List.map (fun ri -> ri.path1) reconItemList, []); if dangerousPaths <> [] then begin Prefs.set Globals.batch false; Util.warn (Uicommon.dangerousPathMsg dangerousPaths) @@ -388,25 +392,72 @@ Update.commitUpdates(); Trace.showTimer t; + let failureList = + Array.fold_right + (fun si l -> + match si.whatHappened with + Some (Util.Failed err) -> + (si, [err], "transport failure") :: l + | _ -> + l) + !theState [] + in + let failureCount = List.length failureList in let failures = - let count = - Array.fold_left - (fun l si -> - l + (match si.whatHappened with Some(Util.Failed(_)) -> 1 | _ -> 0)) - 0 !theState in - if count = 0 then "" else - Printf.sprintf "%d failure%s" count (if count=1 then "" else "s") in + if failureCount = 0 then [] else + [Printf.sprintf "%d failure%s" + failureCount (if failureCount = 1 then "" else "s")] + in + let partialList = + Array.fold_right + (fun si l -> + match si.whatHappened with + Some Util.Succeeded + when partiallyProblematic si.ri && + not (problematic si.ri) -> + let errs = + match si.ri.replicas with + Different diff -> diff.errors1 @ diff.errors2 + | _ -> assert false + in + (si, errs, + "partial transfer (errors during update detection)") :: l + | _ -> + l) + !theState [] + in + let partialCount = List.length partialList in + let partials = + if partialCount = 0 then [] else + [Printf.sprintf "%d partially transferred" partialCount] + in + let skippedList = + Array.fold_right + (fun si l -> + match si.ri.replicas with + Problem err -> + (si, [err], "error during update detection") :: l + | Different diff when diff.direction = Conflict -> + (si, [], + if diff.default_direction = Conflict then + "conflict" + else "skipped") :: l + | _ -> + l) + !theState [] + in + let skippedCount = List.length skippedList in let skipped = - let count = - Array.fold_left - (fun l si -> - l + (if problematic si.ri then 1 else 0)) - 0 !theState in - if count = 0 then "" else - Printf.sprintf "%d skipped" count in + if skippedCount = 0 then [] else + [Printf.sprintf "%d skipped" skippedCount] + in + unsynchronizedPaths := + Some (List.map (fun (si, _, _) -> si.ri.path1) + (failureList @ partialList @ skippedList), + []); Trace.status - (Printf.sprintf "Synchronization complete %s%s%s" - failures (if failures=""||skipped="" then "" else ", ") skipped); + (Printf.sprintf "Synchronization complete %s" + (String.concat ", " (failures @ partials @ skipped))); end;; Callback.register "unisonSynchronize" unisonSynchronize;; Modified: trunk/src/uimacbridgenew.ml =================================================================== --- trunk/src/uimacbridgenew.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/uimacbridgenew.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -18,6 +18,7 @@ mutable whatHappened : Util.confirmation option; mutable statusMessage : string option };; let theState = ref [| |];; +let unsynchronizedPaths = ref None;; let unisonDirectory() = System.fspathToString Os.unisonDir ;; @@ -230,6 +231,7 @@ (* Load the profile and command-line arguments *) (* Restore prefs to their default values, if necessary *) if not !firstTime then Prefs.resetToDefaults(); + unsynchronizedPaths := None; if profileName <> "" then begin (* Tell the preferences module the name of the profile *) @@ -356,7 +358,7 @@ let t = Trace.startTimer "Checking for updates" in let findUpdates () = Trace.status "Looking for changes"; - let updates = Update.findUpdates () in + let updates = Update.findUpdates ~wantWatcher:() !unsynchronizedPaths in Trace.showTimer t; updates in let reconcile updates = Recon.reconcileAll updates in @@ -381,6 +383,8 @@ whatHappened = None; statusMessage = None }) reconItemList in theState := Array.of_list stateItemList; + unsynchronizedPaths := + Some (List.map (fun ri -> ri.path1) reconItemList, []); if dangerousPaths <> [] then begin Prefs.set Globals.batch false; Util.warn (Uicommon.dangerousPathMsg dangerousPaths) @@ -615,36 +619,69 @@ Trace.showTimer t; commitUpdates (); + let failureList = + Array.fold_right + (fun si l -> + match si.whatHappened with + Some (Util.Failed err) -> + (si, [err], "transport failure") :: l + | _ -> + l) + !theState [] + in + let failureCount = List.length failureList in let failures = - let count = - Array.fold_left - (fun l si -> - l + (match si.whatHappened with Some(Util.Failed(_)) -> 1 | _ -> 0)) - 0 !theState in - if count = 0 then [] else - [Printf.sprintf "%d failure%s" count (if count=1 then "" else "s")] in + if failureCount = 0 then [] else + [Printf.sprintf "%d failure%s" + failureCount (if failureCount = 1 then "" else "s")] + in + let partialList = + Array.fold_right + (fun si l -> + match si.whatHappened with + Some Util.Succeeded + when partiallyProblematic si.ri && + not (problematic si.ri) -> + let errs = + match si.ri.replicas with + Different diff -> diff.errors1 @ diff.errors2 + | _ -> assert false + in + (si, errs, + "partial transfer (errors during update detection)") :: l + | _ -> + l) + !theState [] + in + let partialCount = List.length partialList in let partials = - let count = - Array.fold_left - (fun l si -> - l + match si.whatHappened with - Some Util.Succeeded - when partiallyProblematic si.ri && - not (problematic si.ri) -> - 1 - | _ -> - 0) - 0 !theState in - if count = 0 then [] else - [Printf.sprintf "%d partially transferred" count] in + if partialCount = 0 then [] else + [Printf.sprintf "%d partially transferred" partialCount] + in + let skippedList = + Array.fold_right + (fun si l -> + match si.ri.replicas with + Problem err -> + (si, [err], "error during update detection") :: l + | Different diff when diff.direction = Conflict -> + (si, [], + if diff.default_direction = Conflict then + "conflict" + else "skipped") :: l + | _ -> + l) + !theState [] + in + let skippedCount = List.length skippedList in let skipped = - let count = - Array.fold_left - (fun l si -> - l + (if problematic si.ri then 1 else 0)) - 0 !theState in - if count = 0 then [] else - [Printf.sprintf "%d skipped" count] in + if skippedCount = 0 then [] else + [Printf.sprintf "%d skipped" skippedCount] + in + unsynchronizedPaths := + Some (List.map (fun (si, _, _) -> si.ri.path1) + (failureList @ partialList @ skippedList), + []); Trace.status (Printf.sprintf "Synchronization complete %s" (String.concat ", " (failures @ partials @ skipped))); Modified: trunk/src/uitext.ml =================================================================== --- trunk/src/uitext.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/uitext.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -654,7 +654,7 @@ end end -let synchronizeOnce () = +let synchronizeOnce ?wantWatcher ?skipRecentFiles pathsOpt = let showStatus path = if path = "" then Util.set_infos "" else let max_len = 70 in @@ -675,7 +675,7 @@ debug (fun() -> Util.msg "temp: Globals.paths = %s\n" (String.concat " " (Safelist.map Path.toString (Prefs.read Globals.paths)))); - let updates = Update.findUpdates() in + let updates = Update.findUpdates ?wantWatcher pathsOpt in Uutil.setUpdateStatusPrinter None; Util.set_infos ""; @@ -698,192 +698,79 @@ (exitStatus, failedPaths) end -let originalValueOfPathsPreference = ref [] - (* ----------------- Filesystem watching mode ---------------- *) -(* FIX: we should check that the child process has not died and - restart it if so... *) +let watchinterval = 1. (* Minimal interval between two synchronizations *) +let retrydelay = 5. (* Minimal delay to retry failed paths *) +let maxdelay = 30. *. 60. (* Maximal delay to retry failed paths *) -(* FIX: the names of the paths being watched should get included - in the name of the watcher's state file *) +module PathMap = Map.Make (Path) -let watchinterval = 5 - -let watcherTemp r n = - let s = n ^ (Update.archiveHash (Fspath.canonize (Some r))) in - Os.fileInUnisonDir s - -let watchercmd r = - (* FIX: is the quoting of --follow parameters going to work on Win32? - (2/2012: tried adding Uutil.quotes -- maybe this is OK now?) *) - (* FIX -- need to find the program using watcherosx preference *) - let root = Fspath.toString (snd r) in - let changefile = watcherTemp root "changes" in - let statefile = watcherTemp root "state" in - let paths = Safelist.map Path.toString !originalValueOfPathsPreference in - let followpaths = Pred.extern Path.followPred in - let follow = Safelist.map - (fun s -> "--follow '" ^ Uutil.quotes s ^ "'") - followpaths in -(* BCP (per Josh Berdine, 5/2012): changed startup command from this... - let cmd = Printf.sprintf "fsmonitor.py %s --outfile %s --statefile %s %s %s\n" - ... to this: *) - let fsmonfile = Filename.concat (Filename.dirname Sys.executable_name) "fsmonitor.py" in - let cmd = Printf.sprintf "python \"%s\" \"%s\" --outfile \"%s\" --statefile \"%s\" %s %s\n" - fsmonfile - root - (System.fspathToPrintString changefile) - (System.fspathToPrintString statefile) - (String.concat " " follow) - (String.concat " " paths) in - debug (fun() -> Util.msg "watchercmd = %s\n" cmd); - (changefile,cmd) - -module RootMap = Map.Make (struct type t = Common.root - let compare = Pervasives.compare - end) -(* Using string concatenation to accumulate characters is - a bit inefficient, but it's not clear how much it matters in the - grand scheme of things. Current experience suggests that this - implementation performs well enough. *) -type watcherinfo = {file: System.fspath; - ch:Pervasives.in_channel option ref; - chars: string ref; - lines: string list ref} -let watchers : watcherinfo RootMap.t ref = ref RootMap.empty - -let trim_duplicates l = - let rec loop l = match l with - [] -> l - | [s] -> l - | s1::s2::rest -> - if Util.startswith s1 s2 || Util.startswith s2 s1 then - loop (s2::rest) - else - s1 :: (loop (s2::rest)) in - loop (Safelist.sort String.compare l) - -let getAvailableLinesFromWatcher wi = - let ch = match !(wi.ch) with Some(c) -> c | None -> assert false in - let rec loop () = - match try Some(input_char ch) with End_of_file -> None with - None -> - let res = !(wi.lines) in - wi.lines := []; - trim_duplicates res - | Some(c) -> - if c = '\n' then begin - wi.lines := !(wi.chars) :: !(wi.lines); - wi.chars := ""; - loop () - end else begin - wi.chars := (!(wi.chars)) ^ (String.make 1 c); - loop () - end in - loop () - -let suckOnWatcherFileLocal r = - Util.convertUnixErrorsToFatal - "Reading changes from watcher process " - (fun () -> - (* Make sure there's a watcher running *) - try - let wi = RootMap.find r !watchers in - if !(wi.ch) = None then - (* Watcher channel not built yet *) - if System.file_exists wi.file then begin - (* Build it and go *) - let c = System.open_in_bin wi.file in - wi.ch := Some(c); - getAvailableLinesFromWatcher wi - end else begin - (* Wait for change file to be built *) - debug (fun() -> Util.msg - "Waiting for change file %s\n" - (System.fspathToPrintString wi.file)); - [] - end - else begin - (* Watcher running and channel built: go ahead and read *) - getAvailableLinesFromWatcher wi - end - with Not_found -> begin - (* Watcher process not running *) - let (changefile,cmd) = watchercmd r in - debug (fun() -> Util.msg - "Starting watcher on root %s\n" (Common.root2string r)); - let _ = System.open_process_out cmd in - let wi = {file = changefile; ch = ref None; - lines = ref []; chars = ref ""} in - watchers := RootMap.add r wi !watchers; - [] - end) - -let suckOnWatcherFileRoot: Common.root -> Common.root -> (string list) Lwt.t = +let waitForChangesRoot: Common.root -> unit -> unit Lwt.t = Remote.registerRootCmd - "suckOnWatcherFile" - (fun (fspath, r) -> - Lwt.return (suckOnWatcherFileLocal r)) + "waitForChanges" + (fun (fspath, _) -> Fswatchold.wait (Update.archiveHash fspath)) -let suckOnWatcherFiles () = - Safelist.concat - (Lwt_unix.run ( - Globals.allRootsMap (fun r -> suckOnWatcherFileRoot r r))) +let waitForChanges t = + let dt = t -. Unix.gettimeofday () in + if dt > 0. then begin + let timeout = if dt <= maxdelay then [Lwt_unix.sleep dt] else [] in + Lwt_unix.run + (Globals.allRootsMap (fun r -> Lwt.return (waitForChangesRoot r ())) + >>= fun l -> + Lwt.choose (timeout @ l)) + end -let shouldNotIgnore p = - let rec test prefix rest = - if Globals.shouldIgnore prefix then - false - else match (Path.deconstruct rest) with - None -> true - | Some(n,rest') -> - test (Path.child prefix n) rest' - in - test Path.empty (Path.fromString p) - let synchronizePathsFromFilesystemWatcher () = - (* Make sure the confirmbigdeletes preference is turned off. If it's on, - then all deletions will fail because every deletion will count as - a "big deletion"! *) - Prefs.set Globals.confirmBigDeletes false; + let rec loop isStart delayInfo = + let t = Unix.gettimeofday () in + let (delayedPaths, readyPaths) = + PathMap.fold + (fun p (t', _) (delayed, ready) -> + if t' <= t then (delayed, p :: ready) else (p :: delayed, ready)) + delayInfo ([], []) + in + let (exitStatus, failedPaths) = + synchronizeOnce ~wantWatcher:() ~skipRecentFiles:() + (if isStart then None else Some (readyPaths, delayedPaths)) + in + (* After a failure, we retry at once, then use an exponential backoff *) + let delayInfo = + Safelist.fold_left + (fun newDelayInfo p -> + PathMap.add p + (try + let (t', d) = PathMap.find p delayInfo in + if t' > t then (t', d) else + let d = max retrydelay (min maxdelay (2. *. d)) in + (t +. d, d) + with Not_found -> + (t, 0.)) + newDelayInfo) + PathMap.empty + (Safelist.append delayedPaths failedPaths) + in + Lwt_unix.run (Lwt_unix.sleep watchinterval); + let nextTime = + PathMap.fold (fun _ (t, d) t' -> min t t') delayInfo 1e20 in + waitForChanges nextTime; + loop false delayInfo + in + loop true PathMap.empty - let rec loop failedPaths = - let newpathsraw = suckOnWatcherFiles () in - debug (fun () -> Util.msg - "Changed paths: %s\n" (String.concat " " newpathsraw)); - let newpaths = Safelist.filter shouldNotIgnore newpathsraw in - if newpaths <> [] then - display (Printf.sprintf "Changed paths: %s%s\n" - (if newpaths=[] then "" else "\n ") - (String.concat "\n " newpaths)); - let p = failedPaths @ (Safelist.map Path.fromString newpaths) in - if p <> [] then begin - Prefs.set Globals.paths p; - let (exitStatus,newFailedPaths) = synchronizeOnce() in - debug (fun() -> Util.msg "Sleeping for %d seconds...\n" watchinterval); - Unix.sleep watchinterval; - loop newFailedPaths - end else begin - debug (fun() -> Util.msg "Nothing changed: sleeping for %d seconds...\n" - watchinterval); - Unix.sleep watchinterval; - loop [] - end in - loop [] - (* ----------------- Repetition ---------------- *) -let synchronizeUntilNoFailures () = - let rec loop triesLeft = - let (exitStatus,failedPaths) = synchronizeOnce() in +let synchronizeUntilNoFailures repeatMode = + let rec loop triesLeft pathsOpt = + let (exitStatus, failedPaths) = + synchronizeOnce + ?wantWatcher:(if repeatMode then Some () else None) pathsOpt in if failedPaths <> [] && triesLeft <> 0 then begin - loop (triesLeft - 1) + loop (triesLeft - 1) (Some (failedPaths, [])) end else begin - Prefs.set Globals.paths !originalValueOfPathsPreference; exitStatus end in - loop (Prefs.read Uicommon.retry) + loop (Prefs.read Uicommon.retry) None let rec synchronizeUntilDone () = let repeatinterval = @@ -898,7 +785,7 @@ ^Prefs.read Uicommon.repeat ^") should be either a number or 'watch'\n")) in - let exitStatus = synchronizeUntilNoFailures() in + let exitStatus = synchronizeUntilNoFailures(repeatinterval >= 0) in if repeatinterval < 0 then exitStatus else begin @@ -958,10 +845,6 @@ setWarnPrinter(); Trace.statusFormatter := formatStatus; - (* Save away the user's path preferences in case they are needed for - restarting/repeating *) - originalValueOfPathsPreference := Prefs.read Globals.paths; - let exitStatus = synchronizeUntilDone() in (* Put the terminal back in "sane" mode, if necessary, and quit. *) Modified: trunk/src/update.ml =================================================================== --- trunk/src/update.ml 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/update.ml 2012-08-09 14:06:21 UTC (rev 504) @@ -1074,7 +1074,66 @@ (Os.myCanonicalHostName ())))) (Prefs.read mountpoints) +(*********************************************************************** + Set of paths +************************************************************************) +type pathTree = PathTreeLeaf + | PathTreeNode of pathTree NameMap.t + +let rec addPathToTree path tree = + match Path.deconstruct path, tree with + None, _ | _, Some PathTreeLeaf -> + PathTreeLeaf + | Some (nm, p), None -> + PathTreeNode (NameMap.add nm (addPathToTree p None) NameMap.empty) + | Some (nm, p), Some (PathTreeNode children) -> + let t = try Some (NameMap.find nm children) with Not_found -> None in + PathTreeNode (NameMap.add nm (addPathToTree p t) children) + +let rec removePathFromTree path tree = + match Path.deconstruct path, tree with + None, _ -> + None + | Some (nm, p), PathTreeLeaf -> + Some tree + | Some (nm, p), PathTreeNode children -> + try + let t = NameMap.find nm children in + match removePathFromTree p t with + None -> + let newChildren = NameMap.remove nm children in + if NameMap.is_empty children then None else + Some (PathTreeNode newChildren) + | Some t -> + Some (PathTreeNode (NameMap.add nm t children)) + with Not_found -> + Some tree + +let pathTreeOfList l = + Safelist.fold_left (fun t p -> Some (addPathToTree p t)) None l + +let removePathsFromTree l treeOpt = + Safelist.fold_left + (fun t p -> + match t with + None -> None + | Some t -> removePathFromTree p t) + treeOpt l + +let rec getSubTree path tree = + match Path.deconstruct path, tree with + None, _ -> + Some tree + | Some (nm, p), PathTreeLeaf -> + Some PathTreeLeaf + | Some (nm, p), PathTreeNode children -> + try + let t = NameMap.find nm children in + getSubTree p t + with Not_found -> + None + (*********************************************************************** UPDATE DETECTION ************************************************************************) @@ -1126,6 +1185,7 @@ { fastCheck : bool; dirFastCheck : bool; dirStamp : Props.dirChangedStamp; + archHash : string; showStatus : bool } (** Status display **) @@ -1423,9 +1483,11 @@ let path' = Path.child path nm in debugverbose (fun () -> Util.msg "buildUpdateChildren(handleChild): %s\n" (Path.toString path')); - (* BCP 6/10: Added check for ignored path, but I'm not completely - sure this is the right place for it: *) if Globals.shouldIgnore path' then begin + (* We have to ignore paths which are in the archive but no + longer exists in the filesystem. Note that we cannot + reach this point for files that exists on the filesystem + ([hasIgnoredChildren] below would have been true). *) debugignore (fun()->Util.msg "buildUpdateChildren: ignoring path %s\n" (Path.toString path')); archive @@ -1628,6 +1690,98 @@ with Util.Transient(s) -> None, Error(s) +(* Compute the updates for the tree of paths [tree] against archive. *) +let rec buildUpdatePathTree archive fspath here tree scanInfo = + match tree, archive with + PathTreeNode children, ArchiveDir (archDesc, archChildren) -> + let curChildren = + lazy (List.fold_left (fun m (nm, st) -> NameMap.add nm st m) + NameMap.empty (getChildren fspath here)) + in + let updates = ref [] in + let archUpdated = ref false in + let newChi = ref archChildren in + let handleChild nm archive status tree' = + let path' = Path.child here nm in + if Os.isTempFile (Name.toString nm) || Globals.shouldIgnore path' then + archive + else begin + match status with + `Ok | `Abs -> + let (arch,uiChild) = + buildUpdatePathTree archive fspath path' tree' scanInfo in + if uiChild <> NoUpdates then + updates := (nm, uiChild) :: !updates; + begin match arch with + None -> archive + | Some arch -> archUpdated := true; arch + end + | `Dup -> + let uiChild = + Error + ("Two or more files on a case-sensitive system have names \ + identical except for case. They cannot be synchronized \ + to a case-insensitive file system. (File '" ^ + Path.toString path' ^ "')") + in + updates := (nm, uiChild) :: !updates; + archive + | `BadEnc -> + let uiChild = + Error ("The file name is not encoded in Unicode. (File '" + ^ Path.toString path' ^ "')") + in + updates := (nm, uiChild) :: !updates; + archive + | `BadName -> + let uiChild = + Error + ("The name of this Unix file is not allowed under Windows. \ + (File '" ^ Path.toString path' ^ "')") + in + updates := (nm, uiChild) :: !updates; + archive + end + in + NameMap.iter + (fun nm tree' -> + let inArchive = NameMap.mem nm archChildren in + let arch = + if tree' = PathTreeLeaf || not inArchive then begin + let (nm', st) = + try + NameMap.findi nm (Lazy.force curChildren) + with Not_found -> try + (fst (NameMap.findi nm archChildren), `Abs) + with Not_found -> + (nm, `Abs) + in + let arch = + try NameMap.find nm archChildren with Not_found -> NoArchive + in + handleChild nm' arch st tree' + end else begin + let (nm', arch) = NameMap.findi nm archChildren in + handleChild nm' arch `Ok tree' + end + in + if inArchive then newChi := NameMap.add nm arch !newChi) + children; + (begin if !archUpdated then + Some (ArchiveDir (archDesc, !newChi)) + else + None + end, + if !updates <> [] then + (* The Recon module relies on the updates to be sorted *) + Updates (Dir (archDesc, Safelist.rev !updates, PropsSame, false), + oldInfoOf archive) + else + NoUpdates) + | _ -> + showStatus scanInfo here; + buildUpdateRec archive fspath here scanInfo + (* Compute the updates for [path] against archive. Also returns an archive, which is the old archive with time stamps updated appropriately (i.e., for those files whose contents remain @@ -1635,12 +1789,11 @@ contents. The directory permissions along the path are also collected, in case we need to build the directory hierarchy on one side. *) -let rec buildUpdate archive fspath fullpath here path dirStamp scanInfo = +let rec buildUpdate archive fspath fullpath here path pathTree scanInfo = match Path.deconstruct path with None -> - showStatus scanInfo here; let (arch, ui) = - buildUpdateRec archive fspath here scanInfo in + buildUpdatePathTree archive fspath here pathTree scanInfo in (begin match arch with None -> archive | Some arch -> arch @@ -1707,8 +1860,8 @@ let otherChildren = NameMap.remove name children in let (arch, updates, localPath, props) = buildUpdate - archChild fspath fullpath (Path.child here name') path' - dirStamp scanInfo + archChild fspath fullpath (Path.child here name') + path' pathTree scanInfo in let children = if arch = NoArchive then otherChildren else @@ -1720,8 +1873,8 @@ | _ -> let (arch, updates, localPath, props) = buildUpdate - NoArchive fspath fullpath (Path.child here name') path' - dirStamp scanInfo + NoArchive fspath fullpath (Path.child here name') + path' pathTree scanInfo in assert (arch = NoArchive); (archive, updates, localPath, @@ -1766,10 +1919,16 @@ (Proplist.add rsrcKey newRsrc props))); stamp +(* This contains the list of synchronized paths and the directory stamps + used by the previous update detection, when a watcher process is used. + This make it possible to know when the state of the watcher process + needs to be reset. *) +let previousFindOptions = Hashtbl.create 7 + (* for the given path, find the archive and compute the list of update items; as a side effect, update the local archive w.r.t. time-stamps for unchanged files *) -let findLocal fspath pathList: +let findLocal wantWatcher fspath pathList subpaths : (Path.local * Common.updateItem * Props.t list) list = debug (fun() -> Util.msg "findLocal %s (%s)\n" (Fspath.toDebugString fspath) @@ -1793,24 +1952,79 @@ as Windows does not update directory modification times on FAT filesystems. *) dirFastCheck = useFastChecking () && Util.osType = `Unix; - dirStamp = dirStamp; + dirStamp = dirStamp; archHash = archiveHash fspath; showStatus = not !Trace.runningasserver } in let (cacheFilename, _) = archiveName fspath FPCache in let cacheFile = Os.fileInUnisonDir cacheFilename in Fpcache.init scanInfo.fastCheck (Prefs.read ignoreArchives) cacheFile; + let unchangedOptions = + try + Hashtbl.find previousFindOptions scanInfo.archHash + = (scanInfo.dirStamp, pathList) + with Not_found -> + false + in + let paths = + match subpaths with + Some (unsynchronizedPaths, blacklistedPaths) when unchangedOptions -> + let (>>) x f = f x in + let paths = + Fswatchold.getChanges scanInfo.archHash + (* We do not really need to filter here (they are filtered also + by [buildUpdatePathTree], but that might reduce greatly and + cheaply number of paths to consider... *) + >> List.filter (fun path -> not (Globals.shouldIgnore path)) + in + let filterPaths paths subpaths = + let number_list l = + let i = ref (-1) in + Safelist.map (fun x -> incr i; (!i, x)) l + in + paths >> (* We number paths, to be able to recover their + initial order. *) + number_list + >> (* We put longest paths first, in order to deal + correctly with nested paths (tough that might be + overkill...) *) + List.sort (fun (_, p1) (_, p2) -> Path.compare p2 p1) + >> (* We extract the set of changed paths included in + each synchronized path *) + List.fold_left + (fun (l, tree) (i, p) -> + match tree with + None -> + ((i, (p, None)) :: l, None) + | Some tree -> + ((i, (p, getSubTree p tree)) :: l, + removePathFromTree p tree)) + ([], pathTreeOfList subpaths) + >> fst + >> (* Finally, we restaure the initial order *) + List.sort (fun (i1, _) (i2, _) -> compare i1 i2) + >> List.map snd + in + filterPaths pathList (Safelist.append unsynchronizedPaths paths) + | _ -> + if wantWatcher && Fswatchold.start scanInfo.archHash fspath then + Hashtbl.replace previousFindOptions + scanInfo.archHash (scanInfo.dirStamp, pathList) + else + Hashtbl.remove previousFindOptions scanInfo.archHash; + Safelist.map (fun p -> (p, Some PathTreeLeaf)) pathList + in let (archive, updates) = Safelist.fold_right - (fun path (arch, upd) -> - if Globals.shouldIgnore path then - (arch, (translatePathLocal fspath path, NoUpdates, []) :: upd) - else - let (arch', ui, localPath, props) = - buildUpdate - arch fspath path Path.empty path dirStamp scanInfo - in - arch', (localPath, ui, props) :: upd) - pathList (archive, []) + (fun (path, pathTreeOpt) (arch, upd) -> + match pathTreeOpt with + Some pathTree when not (Globals.shouldIgnore path) -> + let (arch', ui, localPath, props) = + buildUpdate arch fspath path Path.empty path pathTree scanInfo + in + (arch', (localPath, ui, props) :: upd) + | _ -> + (arch, (translatePathLocal fspath path, NoUpdates, []) :: upd)) + paths (archive, []) in Fpcache.finish (); (* @@ -1824,10 +2038,10 @@ let findOnRoot = Remote.registerRootCmd "find" - (fun (fspath, pathList) -> - Lwt.return (findLocal fspath pathList)) + (fun (fspath, (wantWatcher, pathList, subpaths)) -> + Lwt.return (findLocal wantWatcher fspath pathList subpaths)) -let findUpdatesOnPaths pathList = +let findUpdatesOnPaths ?wantWatcher pathList subpaths = Lwt_unix.run (loadArchives true >>= (fun (ok, checksums) -> begin if ok then Lwt.return checksums else begin @@ -1850,7 +2064,7 @@ let t = Trace.startTimer "Collecting changes" in Globals.allRootsMapWithWaitingAction (fun r -> debug (fun() -> Util.msg "findOnRoot %s\n" (root2string r)); - findOnRoot r pathList) + findOnRoot r (wantWatcher <> None, pathList, subpaths)) (fun (host, _) -> begin match host with Remote _ -> Uutil.showUpdateStatus ""; @@ -1870,10 +2084,10 @@ Trace.status ""; Lwt.return result)))) -let findUpdates () = +let findUpdates ?wantWatcher subpaths = (* TODO: We should filter the paths to remove duplicates (including prefixes) and ignored paths *) - findUpdatesOnPaths (Prefs.read Globals.paths) + findUpdatesOnPaths ?wantWatcher (Prefs.read Globals.paths) subpaths (*****************************************************************************) @@ -2253,7 +2467,7 @@ (* ...and check that this is a good description of what's out in the world *) let scanInfo = { fastCheck = false; dirFastCheck = false; - dirStamp = Props.changedDirStamp; + dirStamp = Props.changedDirStamp; archHash = "" (* Not used *); showStatus = false } in let (_, uiNew) = buildUpdateRec archive fspath localPath scanInfo in markPossiblyUpdatedRec fspath pathInArchive uiNew; Modified: trunk/src/update.mli =================================================================== --- trunk/src/update.mli 2012-08-07 20:06:46 UTC (rev 503) +++ trunk/src/update.mli 2012-08-09 14:06:21 UTC (rev 504) @@ -18,10 +18,16 @@ (* Retrieve the actual names of the roots *) val getRootsName : unit -> string -(* Structures describing dirty files/dirs (1 per path given in the -path preference) *) +(* Perform update detection. Optionally, takes as input the list of + paths known not to be synchronized and a list of paths not to + check. Returns structures describing dirty files/dirs (1 per path + given in the -path preference). An option controls whether we + would like to use the external filesytem monitoring process. *) val findUpdates : - unit -> ((Path.local * Common.updateItem * Props.t list) * - (Path.local * Common.updateItem * Props.t list)) list + ?wantWatcher:unit -> + (Path.t list * Path.t list) option -> + ((Path.local * Common.updateItem * Props.t list) * + (Path.local * Common.updateItem * Props.t list)) list (* Take a tree of equal update contents and update the archive accordingly. *) val markEqual : From vouillon at seas.upenn.edu Thu Aug 9 10:22:34 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Thu, 9 Aug 2012 10:22:34 -0400 Subject: [Unison-hackers] [unison-svn] r505 - trunk/src Message-ID: <201208091422.q79EMY9h024482@yaws.seas.upenn.edu> Author: vouillon Date: 2012-08-09 10:22:34 -0400 (Thu, 09 Aug 2012) New Revision: 505 Modified: trunk/src/RECENTNEWS trunk/src/copy.ml trunk/src/copy.mli trunk/src/files.ml trunk/src/files.mli trunk/src/mkProjectInfo.ml trunk/src/path.ml trunk/src/path.mli trunk/src/stasher.ml trunk/src/transport.ml Log: * Added a "copyonconflict" preference, to make a copy of files that would otherwise be overwritten or deleted in case of conflicting changes. (This makes it possible to automatically resolve conflicts in a fairly safe way when synchronizing continuously, in combination with the "repeat = watch" and "prefer = newer" preferences. Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/RECENTNEWS 2012-08-09 14:22:34 UTC (rev 505) @@ -1,3 +1,12 @@ +CHANGES FROM VERSION 2.46.0 + +* Added a "copyonconflict" preference, to make a copy of files that would + otherwise be overwritten or deleted in case of conflicting changes. + (This makes it possible to automatically resolve conflicts in a + fairly safe way when synchronizing continuously, in combination + with the "repeat = watch" and "prefer = newer" preferences. + +------------------------------- CHANGES FROM VERSION 2.46.-1 * Bumped version number: incompatible protocol changes Modified: trunk/src/copy.ml =================================================================== --- trunk/src/copy.ml 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/copy.ml 2012-08-09 14:22:34 UTC (rev 505) @@ -977,3 +977,36 @@ >>= fun () -> (* This function never returns (it is supposed to fail) *) saveTempFileOnRoot rootTo (pathTo, realPathTo, reason) + +(****) + +let recursively fspathFrom pathFrom fspathTo pathTo = + let rec copy pFrom pTo = + let info = Fileinfo.get true fspathFrom pFrom in + match info.Fileinfo.typ with + | `SYMLINK -> + debug (fun () -> Util.msg " Copying link %s / %s to %s / %s\n" + (Fspath.toDebugString fspathFrom) (Path.toString pFrom) + (Fspath.toDebugString fspathTo) (Path.toString pTo)); + Os.symlink fspathTo pTo (Os.readLink fspathFrom pFrom) + | `FILE -> + debug (fun () -> Util.msg " Copying file %s / %s to %s / %s\n" + (Fspath.toDebugString fspathFrom) (Path.toString pFrom) + (Fspath.toDebugString fspathTo) (Path.toString pTo)); + localFile fspathFrom pFrom fspathTo pTo pTo + `Copy info.Fileinfo.desc + (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) None + | `DIRECTORY -> + debug (fun () -> Util.msg " Copying directory %s / %s to %s / %s\n" + (Fspath.toDebugString fspathFrom) (Path.toString pFrom) + (Fspath.toDebugString fspathTo) (Path.toString pTo)); + Os.createDir fspathTo pTo info.Fileinfo.desc; + let ch = Os.childrenOf fspathFrom pFrom in + Safelist.iter + (fun n -> copy (Path.child pFrom n) (Path.child pTo n)) ch + | `ABSENT -> assert false in + debug (fun () -> Util.msg " Copying recursively %s / %s\n" + (Fspath.toDebugString fspathFrom) (Path.toString pathFrom)); + copy pathFrom pathTo; + debug (fun () -> Util.msg " Finished copying %s / %s\n" + (Fspath.toDebugString fspathFrom) (Path.toString pathTo)) Modified: trunk/src/copy.mli =================================================================== --- trunk/src/copy.mli 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/copy.mli 2012-08-09 14:22:34 UTC (rev 505) @@ -26,3 +26,10 @@ -> Uutil.Filesize.t (* fork length *) -> Uutil.File.t option (* file's index in UI (for progress bars), if appropriate *) -> unit + +val recursively : + Fspath.t (* fspath of source *) + -> Path.local (* path of source *) + -> Fspath.t (* fspath of target *) + -> Path.local (* path of target *) + -> unit Modified: trunk/src/files.ml =================================================================== --- trunk/src/files.ml 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/files.ml 2012-08-09 14:22:34 UTC (rev 505) @@ -72,14 +72,52 @@ (* ------------------------------------------------------------ *) -let deleteLocal (fspathTo, (pathTo, ui)) = +let copyOnConflict = Prefs.createBool "copyonconflict" false + "!keep copies of conflicting files" + "When this flag is set, Unison will make a copy of files that would \ + otherwise be overwritten or deleted in case of conflicting changes, \ + and more generally whenever the default behavior is overriden. \ + This makes it possible to automatically resolve conflicts in a \ + fairly safe way when synchronizing continuously, in combination \ + with the \\verb|-repeat watch| and \\verb|-prefer newer| preferences." + +let prepareCopy workingDir path notDefault = + if notDefault && Prefs.read copyOnConflict then begin + let tmpPath = Os.tempPath workingDir path in + Copy.recursively workingDir path workingDir tmpPath; + Some (workingDir, path, tmpPath) + end else + None + +let finishCopy copyInfo = + match copyInfo with + Some (workingDir, path, tmpPath) -> + let tm = Unix.localtime (Unix.gettimeofday ()) in + let rec copyPath n = + let p = + Path.addToFinalName path + (Format.sprintf " (copy: conflict%s on %04d-%02d-%02d)" + (if n = 0 then "" else " #" ^ string_of_int n) + (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday) + in + if Os.exists workingDir p then copyPath (n + 1) else p + in + Os.rename "keepCopy" workingDir tmpPath workingDir (copyPath 0) + | None -> + () + +(* ------------------------------------------------------------ *) + +let deleteLocal (fspathTo, (pathTo, ui, notDefault)) = debug (fun () -> Util.msg "deleteLocal [%s] (None, %s)\n" (Fspath.toDebugString fspathTo) (Path.toString pathTo)); let localPathTo = Update.translatePathLocal fspathTo pathTo in + let copyInfo = prepareCopy fspathTo localPathTo notDefault in (* Make sure the target is unchanged first *) (* (There is an unavoidable race condition here.) *) let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in + finishCopy copyInfo; Stasher.backup fspathTo localPathTo `AndRemove prevArch; (* Archive update must be done last *) Update.replaceArchiveLocal fspathTo localPathTo Update.NoArchive; @@ -87,8 +125,8 @@ let deleteOnRoot = Remote.registerRootCmd "delete" deleteLocal -let delete rootFrom pathFrom rootTo pathTo ui = - deleteOnRoot rootTo (pathTo, ui) >>= fun _ -> +let delete rootFrom pathFrom rootTo pathTo ui notDefault = + deleteOnRoot rootTo (pathTo, ui, notDefault) >>= fun _ -> Update.replaceArchive rootFrom pathFrom Update.NoArchive (* ------------------------------------------------------------ *) @@ -268,10 +306,13 @@ temp file into place, but remain able to roll back if something fails either locally or on the other side. *) let renameLocal - (fspathTo, (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt)) = + (fspathTo, + (localPathTo, workingDir, pathFrom, pathTo, ui, archOpt, notDefault)) = + let copyInfo = prepareCopy workingDir pathTo notDefault in (* Make sure the target is unchanged, then do the rename. (Note that there is an unavoidable race condition here...) *) let prevArch = Update.checkNoUpdates fspathTo localPathTo ui in + finishCopy copyInfo; performRename fspathTo localPathTo workingDir pathFrom pathTo prevArch; begin match archOpt with Some archTo -> Stasher.stashCurrentVersion fspathTo localPathTo None; @@ -285,12 +326,13 @@ let renameOnHost = Remote.registerRootCmd "rename" renameLocal -let rename root localPath workingDir pathOld pathNew ui archOpt = +let rename root localPath workingDir pathOld pathNew ui archOpt notDefault = debug (fun() -> Util.msg "rename(root=%s, pathOld=%s, pathNew=%s)\n" (root2string root) (Path.toString pathOld) (Path.toString pathNew)); - renameOnHost root (localPath, workingDir, pathOld, pathNew, ui, archOpt) + renameOnHost root + (localPath, workingDir, pathOld, pathNew, ui, archOpt, notDefault) (* ------------------------------------------------------------ *) @@ -431,6 +473,7 @@ this updateItem still describes the current state of the target replica) *) propsTo (* the properties of the parent directories *) + notDefault (* [true] if not Unison's default action *) id = (* for progress display *) debug (fun() -> Util.msg @@ -564,7 +607,7 @@ (* Rename the files to their final location and then update the archive on the destination replica *) rename rootTo localPathTo workingDir tempPathTo realPathTo uiTo - (Some archTo) >>= fun () -> + (Some archTo) notDefault >>= fun () -> (* Update the archive on the source replica FIX: we could reuse localArch if rootFrom is the same as rootLocal *) updateSourceArchive rootFrom (localPathFrom, uiFrom, errPaths) >>= fun () -> @@ -748,7 +791,7 @@ (Local, fspathFrom) pathFrom rootTo workingDirForCopy tempPathTo realPathTo `Copy newprops fp None stamp id >>= fun info -> rename rootTo localPathTo workingDirForCopy tempPathTo realPathTo - uiTo None) + uiTo None false) let keeptempfilesaftermerge = Prefs.createBool Modified: trunk/src/files.mli =================================================================== --- trunk/src/files.mli 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/files.mli 2012-08-09 14:22:34 UTC (rev 505) @@ -11,6 +11,7 @@ -> Common.root (* root *) -> Path.t (* path to delete *) -> Common.updateItem (* updates that will be discarded *) + -> bool (* [true] if not Unison's default action *) -> unit Lwt.t (* Region used for the copying. Exported to be correctly set in transport.ml *) @@ -31,6 +32,7 @@ -> Path.t (* to what path *) -> Common.updateItem (* dest. updates *) -> Props.t list (* properties of parent directories *) + -> bool (* [true] if not Unison's default action *) -> Uutil.File.t (* id for showing progress of transfer *) -> unit Lwt.t Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/mkProjectInfo.ml 2012-08-09 14:22:34 UTC (rev 505) @@ -79,3 +79,4 @@ + Modified: trunk/src/path.ml =================================================================== --- trunk/src/path.ml 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/path.ml 2012-08-09 14:22:34 UTC (rev 505) @@ -188,6 +188,14 @@ let addSuffixToFinalName path suffix = path ^ suffix +let addToFinalName path suffix = + let l = String.length path in + assert (l > 0); + let i = try String.rindex path '/' with Not_found -> -1 in + let j = try String.rindex path '.' with Not_found -> -1 in + let j = if j <= i then l else j in + String.sub path 0 j ^ suffix ^ String.sub path j (l - j) + let addPrefixToFinalName path prefix = try let i = String.rindex path pathSeparatorChar + 1 in Modified: trunk/src/path.mli =================================================================== --- trunk/src/path.mli 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/path.mli 2012-08-09 14:22:34 UTC (rev 505) @@ -29,6 +29,8 @@ val addSuffixToFinalName : local -> string -> local val addPrefixToFinalName : local -> string -> local +val addToFinalName : local -> string -> local + (* Add to the final name, but before any file extension. *) val compare : t -> t -> int val equal : local -> local -> bool Modified: trunk/src/stasher.ml =================================================================== --- trunk/src/stasher.ml 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/stasher.ml 2012-08-09 14:22:34 UTC (rev 505) @@ -382,32 +382,7 @@ (Fspath.toDebugString fspath) (Path.toString path) (Path.toString backPath) (Fspath.toDebugString backRoot)); let byCopying() = - let rec copy p backp = - let info = Fileinfo.get true fspath p in - match info.Fileinfo.typ with - | `SYMLINK -> - debug (fun () -> Util.msg " Copying link %s / %s to %s / %s\n" - (Fspath.toDebugString fspath) (Path.toString p) - (Fspath.toDebugString backRoot) (Path.toString backp)); - Os.symlink backRoot backp (Os.readLink fspath p) - | `FILE -> - debug (fun () -> Util.msg " Copying file %s / %s to %s / %s\n" - (Fspath.toDebugString fspath) (Path.toString p) - (Fspath.toDebugString backRoot) (Path.toString backp)); - Copy.localFile fspath p backRoot backp backp - `Copy info.Fileinfo.desc - (Osx.ressLength info.Fileinfo.osX.Osx.ressInfo) None - | `DIRECTORY -> - debug (fun () -> Util.msg " Copying directory %s / %s to %s / %s\n" - (Fspath.toDebugString fspath) (Path.toString p) - (Fspath.toDebugString backRoot) (Path.toString backp)); - Os.createDir backRoot backp info.Fileinfo.desc; - let ch = Os.childrenOf fspath p in - Safelist.iter (fun n -> copy (Path.child p n) (Path.child backp n)) ch - | `ABSENT -> assert false in - copy path backPath; - debug (fun () -> Util.msg " Finished copying; deleting %s / %s\n" - (Fspath.toDebugString fspath) (Path.toString path)); + Copy.recursively fspath path backRoot backPath; disposeIfNeeded() in begin if finalDisposition = `AndRemove then try Modified: trunk/src/transport.ml =================================================================== --- trunk/src/transport.ml 2012-08-09 14:06:21 UTC (rev 504) +++ trunk/src/transport.ml 2012-08-09 14:22:34 UTC (rev 505) @@ -77,7 +77,8 @@ (fun _ -> Printf.sprintf "[END] %s\n" lwtShortDescription) -let doAction fromRoot fromPath fromContents toRoot toPath toContents id = +let doAction + fromRoot fromPath fromContents toRoot toPath toContents notDefault id = (* When streaming, we can transfer many file simultaneously: as the contents of only one file is transferred in one direction at any time, little resource is consumed this way. *) @@ -98,7 +99,8 @@ ("Deleting " ^ Path.toString toPath ^ "\n from "^ root2string toRoot) ("Deleting " ^ Path.toString toPath) - (fun () -> Files.delete fromRoot fromPath toRoot toPath uiTo) + (fun () -> + Files.delete fromRoot fromPath toRoot toPath uiTo notDefault) (* No need to transfer the whole directory/file if there were only property modifications on one side. (And actually, it would be incorrect to transfer a directory in this case.) *) @@ -120,7 +122,8 @@ ("Updating file " ^ Path.toString toPath) (fun () -> Files.copy (`Update (fileSize uiFrom uiTo)) - fromRoot fromPath uiFrom [] toRoot toPath uiTo [] id) + fromRoot fromPath uiFrom [] toRoot toPath uiTo [] + notDefault id) | {ui = uiFrom; props = propsFrom}, {ui = uiTo; props = propsTo} -> logLwtNumbered ("Copying " ^ Path.toString toPath ^ "\n from " ^ @@ -130,7 +133,8 @@ (fun () -> Files.copy `Copy fromRoot fromPath uiFrom propsFrom - toRoot toPath uiTo propsTo id)) + toRoot toPath uiTo propsTo + notDefault id)) (fun e -> Trace.log (Printf.sprintf "Failed: %s\n" (Util.printException e)); @@ -143,16 +147,20 @@ Trace.log (Printf.sprintf "[ERROR] Skipping %s\n %s\n" (Path.toString path) p); return () - | Different {rc1 = rc1; rc2 = rc2; direction = dir} -> + | Different + {rc1 = rc1; rc2 = rc2; direction = dir; default_direction = def} -> + let notDefault = dir <> def in match dir with Conflict -> Trace.log (Printf.sprintf "[CONFLICT] Skipping %s\n" (Path.toString path)); return () | Replica1ToReplica2 -> - doAction root1 reconItem.path1 rc1 root2 reconItem.path2 rc2 id + doAction + root1 reconItem.path1 rc1 root2 reconItem.path2 rc2 notDefault id | Replica2ToReplica1 -> - doAction root2 reconItem.path2 rc2 root1 reconItem.path1 rc1 id + doAction + root2 reconItem.path2 rc2 root1 reconItem.path1 rc1 notDefault id | Merge -> if rc1.typ <> `FILE || rc2.typ <> `FILE then raise (Util.Transient "Can only merge two existing files"); From vouillon at seas.upenn.edu Thu Aug 9 10:30:22 2012 From: vouillon at seas.upenn.edu (vouillon at seas.upenn.edu) Date: Thu, 9 Aug 2012 10:30:22 -0400 Subject: [Unison-hackers] [unison-svn] r506 - in trunk/src: . fsmonitor fsmonitor/linux fsmonitor/windows lwt lwt/win system Message-ID: <201208091430.q79EUMC8024775@yaws.seas.upenn.edu> 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 + * + * 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 + * + * 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 + * + * 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 +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include + +#if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 4 +#define GLIBC_SUPPORT_INOTIFY 1 +#else +#define GLIBC_SUPPORT_INOTIFY 0 +#endif + +#if GLIBC_SUPPORT_INOTIFY +#include +#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 . +*) + +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 . +*) + +(* +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 . +*) + +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 . +*) + +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 +#include +#include +#include + +#include +#include +#include + +//#include + +#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 . +*) + +(* +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 . +*) + +(* +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 #include #include @@ -3,6 +5,4 @@ #include -#define WINVER 0x0500 - #include #include 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 From cgat at arcor.de Thu Aug 9 11:19:39 2012 From: cgat at arcor.de (cgat at arcor.de) Date: Thu, 9 Aug 2012 17:19:39 +0200 Subject: [Unison-hackers] filesystem watching with stable unison and dev version (was: [unison-svn] r506 - in trunk/src: . fsmonitor ...) Message-ID: <20120809171939.17bc766e@tmp> Hello unison-hackers! Am Thu, 9 Aug 2012 10:30:22 -0400 schrieb vouillon at seas.upenn.edu: > 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. Wow, very nice. Maybe you have already seen my anouncment on unison-users: A bash script that supports filesystem watch based syncing with the current stable unison versions, and can provide a system tray icon. See https://launchpad.net/sucsynct Of course, I would also like it to support the new "-repeat watch" option in the future. While developing the script I had written down some thoughts, that may be interesting to discuss here: --- Ideally, event based syncing will only trigger a sync after a new change event occured, and each sync should only cover those files that have changed. However, two circumstances force us to do some additional change detection. 1) The recursive establishment of inotify watches may miss file creations in new subdirectories, if files are created before a watch could be established on the new subdirectory. Consequently, when a new directory is created, we need to re-scan the whole sub-tree for changes, instead of just relying on the event records. Fortunately, unison can do very fast change detection as it can rely on its database and the filesystem meta-data (at least on non-windows filesystems). 2) An external program, like sucsynct, can not identify the new changes that occur while a sync is in progress, without extensive logfile parsing. There is thus a potenial risk to miss new changes made during syncs. Consequently, external programms usually do periodic syncs in short intervalls (polling), to minimize the delay in change propagation, and with this the risk that conflicting changes may be made concurrently on both replicas. Because the whole point of event based syncing is to avoid needless periodic syncing, some additional attention was necessary to solve 2) in a way that can truly suspend syncing whithout risking to miss a change. The basic concept taken here is to suspended syncing only after a waker could be set up successfully, that is without new changes occuring in the meantime, and to verify this with one extra syncing cycle. What about unison's upcoming "-repeat watch" fsmonitor.py feature? Issue 1 probably applies as well. For 2, unison could filter the first and second occurence of its transfers from the event log an be very carefull with the timing, to avoid a full verification sync. Unison may further keep its data in ram in between syncs, and avoid continous periodic polling of the event file. It could suspend until triggered to read the event file again, once it finds no new events in the event buffer. (Yet, similarly to sucsynct, unison will probably also have to ensure that the separate waker pipe for the event buffer could be set up without missing events, before blocking on reading the pipe.) --- Kind Regards, Christian From bcpierce at cis.upenn.edu Thu Aug 9 18:32:27 2012 From: bcpierce at cis.upenn.edu (Benjamin C. Pierce) Date: Thu, 9 Aug 2012 18:32:27 -0400 Subject: [Unison-hackers] [unison-svn] r506 - in trunk/src: . fsmonitor fsmonitor/linux fsmonitor/windows lwt lwt/win system In-Reply-To: <201208091430.q79EUMC8024775@yaws.seas.upenn.edu> References: <201208091430.q79EUMC8024775@yaws.seas.upenn.edu> Message-ID: 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 > + * > + * 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 > + * > + * 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 > + * > + * 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 > +#include > +#include > +#include > +#include > +#include > +#include > +#include > +#include > +#include > +#include > +#include > + > +#include > + > +#if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 4 > +#define GLIBC_SUPPORT_INOTIFY 1 > +#else > +#define GLIBC_SUPPORT_INOTIFY 0 > +#endif > + > +#if GLIBC_SUPPORT_INOTIFY > +#include > +#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 . > +*) > + > +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 . > +*) > + > +(* > +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 . > +*) > + > +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 . > +*) > + > +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 > +#include > +#include > +#include > + > +#include > +#include > +#include > + > +//#include > + > +#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 . > +*) > + > +(* > +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 . > +*) > + > +(* > +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 > #include > #include > @@ -3,6 +5,4 @@ > #include > > -#define WINVER 0x0500 > - > #include > #include > > 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 From Jerome.Vouillon at pps.jussieu.fr Fri Aug 10 07:56:11 2012 From: Jerome.Vouillon at pps.jussieu.fr (Jerome Vouillon) Date: Fri, 10 Aug 2012 13:56:11 +0200 Subject: [Unison-hackers] [unison-svn] r506 - in trunk/src: . fsmonitor fsmonitor/linux fsmonitor/windows lwt lwt/win system In-Reply-To: References: <201208091430.q79EUMC8024775@yaws.seas.upenn.edu> Message-ID: <20120810115611.GA21158@pps.jussieu.fr> On Thu, Aug 09, 2012 at 06:32:27PM -0400, Benjamin C. Pierce wrote: > Any idea how hard it is to adapt the linux one to OSX? In fact, you should adapt the Windows one, which uses a more similar API (directories are watched recursively). Symlinks are dealt with in the code shared by the different backends, so that comes for free. There is a bit of work, but that should not be hard. The main difficulty is that the Mac OS API needs its own run loop, so it does not integrate well with Lwt. I think the simplest thing to do is to have two threads and use pipes for signalling, a bit as in there: http://cpansearch.perl.org/src/AGRUNDMA/Mac-FSEvents-0.04/FSEvents.xs The other issue is that, before Mac OS 10.7, you only get the directories in which changes happened but not what happened exactly. I don't think it is worthwhile to put much effort in old Mac OS versions, so we can probably just flag the directory to be rescan entirely in this case. -- Jerome