From db5ab2a9e4bad6125673b1c5cdb2d86c11841977 Mon Sep 17 00:00:00 2001
From: Olof-Joachim Frahm <Olof.Frahm@web.de>
Date: Fri, 18 Dec 2009 21:07:23 +0100
Subject: [PATCH] Enhanced functionality and more convenience.

Changed dependency on utils-frahm, non-blocking reading, registration of
watched directories.
---
 cl-notify.asd |    3 +-
 inotify.lisp  |  289 ++++++++++++++++++++++++++++++++++++++++++++-------------
 package.lisp  |   35 +++++--
 3 files changed, 251 insertions(+), 76 deletions(-)

diff --git a/cl-notify.asd b/cl-notify.asd
index 08c4d68..1350e36 100644
--- a/cl-notify.asd
+++ b/cl-notify.asd
@@ -4,7 +4,8 @@
   (asdf:operate 'asdf:load-op 'cffi-grovel))
 
 (asdf:defsystem cl-notify
-  :depends-on (#:cffi #:binary-types)
+  :depends-on (#:cffi #:binary-types #:utils-frahm-common)
+  :serial T
   :components ((:file "package")
 	       (cffi-grovel:grovel-file "grovel")
 	       (:file "inotify")))
diff --git a/inotify.lisp b/inotify.lisp
index 427ff73..b7ddfc2 100644
--- a/inotify.lisp
+++ b/inotify.lisp
@@ -1,108 +1,267 @@
 (in-package #:cl-notify)
 
-(defbitfield (inotify-flags :uint32)
-  (:in-access #.in-access)
-  (:in-modify #.in-modify)
-  (:in-attrib #.in-attrib)
-  (:in-close-write #.in-close-write)
-  (:in-close-nowrite #.in-close-nowrite)
-  (:in-close #.in-close)
-  (:in-open #.in-open)
-  (:in-moved-from #.in-moved-from)
-  (:in-moved-to #.in-moved-to)
-  (:in-move #.in-move)
-  (:in-create #.in-create)
-  (:in-delete #.in-delete)
-  (:in-delete-self #.in-delete-self)
-  (:in-move-self #.in-move-self)
-  (:in-unmount #.in-unmount)
-  (:in-q-overflow #.in-q-overflow)
-  (:in-ignored #.in-ignored)
-  (:in-onlydir #.in-onlydir)
-  (:in-dont-follow #.in-dont-follow)
-  (:in-mask-add #.in-mask-add)
-  (:in-isdir #.in-isdir)
-  (:in-oneshot #.in-oneshot)
-  (:in-all-events #.in-all-events))
-
-(defcfun "inotify_init" :int)
-
-(defcfun "inotify_add_watch" :int
+(defbitfield (inotify-flag :uint32)
+  (:access #.in-access)
+  (:modify #.in-modify)
+  (:attrib #.in-attrib)
+  (:close-write #.in-close-write)
+  (:close-nowrite #.in-close-nowrite)
+  (:close #.in-close)
+  (:open #.in-open)
+  (:moved-from #.in-moved-from)
+  (:moved-to #.in-moved-to)
+  (:move #.in-move)
+  (:create #.in-create)
+  (:delete #.in-delete)
+  (:delete-self #.in-delete-self)
+  (:move-self #.in-move-self)
+  (:unmount #.in-unmount)
+  (:q-overflow #.in-q-overflow)
+  (:ignored #.in-ignored)
+  (:onlydir #.in-onlydir)
+  (:dont-follow #.in-dont-follow)
+  (:mask-add #.in-mask-add)
+  (:isdir #.in-isdir)
+  (:oneshot #.in-oneshot)
+  (:all-events #.in-all-events))
+
+(deftype inotify-add/read-flag ()
+  "Shared valid flags for the WATCH and READ-EVENT functions."
+  '(member
+    :access :attrib 
+    :close-write :close-nowrite :close
+    :create :delete :delete-self
+    :modify
+    :move-self :moved-from :moved-to :move
+    :open :all-events))
+
+(deftype inotify-add-flag ()
+  "Valid flags for the WATCH function."
+  '(or inotify-add/read-flag
+    (member :dont-follow :mask-add :oneshot :onlydir)))
+
+(deftype inotify-read-flag ()
+  "Valid flags which are returned from READ-EVENT."
+  '(or inotify-add/read-flag
+    (member :ignored :isdir :q-overflow :unmount)))
+
+(defcfun ("inotify_init" c-inotify-init) :int
+  "Initialises a new inotify event queue.")
+
+(defcfun ("inotify_add_watch" c-inotify-add-watch) :int
+  "Watches a path on a event queue."
   (fd :int)
   (pathname :string)
-  (mask inotify-flags))
+  (mask inotify-flag))
 
-(defcfun "inotify_rm_watch" :int
+(defcfun ("inotify_rm_watch" c-inotify-rm-watch) :int
+  "Removes a watched path from a event queue."
   (fd :int)
   (wd :int))
 
 (binary-types:define-signed int #.(cffi:foreign-type-size :int))
 
 (binary-types:define-binary-struct inotify-event ()
+  "An inotify native event structure.
+WD is the watch/file descriptor,
+MASK is the (parsed) combination of events,
+COOKIE is a unique integer which connects related events,
+NAME optionally identifies a file relative to a watched directory."
   (wd 0 :binary-type int)
   (mask 0 :binary-type binary-types:u32)
   (cookie 0 :binary-type binary-types:u32)
   (name NIL))
 
-(defstruct (inotify-instance (:constructor make-inotify-instance (fd stream)))
+(defstruct (inotify-instance
+	     (:constructor make-inotify-instance ())
+	     (:conc-name inotify-))
+  "Contains the stream and file descriptor for a inotify instance."
   fd
-  stream)
+  stream
+  nonblocking)
+
+;;;; initialisation and stuff
 
 (defun init-endian ()
+  "Initialises endianess for the BINARY-TYPES library."
   (setf binary-types:*endian*
 	#+little-endian :little-endian
 	#+big-endian :big-endian
 	#-(or little-endian big-endian) (error "unknown endianess")))
 
+;; um, in what evel-when should this be wrapped?
 (init-endian)
 
-(defun inotify-read-raw-event (stream)
+;;;; basic wrapping of the API
+
+(defun read-raw-event (stream)
+  "Reads a raw event from the inotify stream."
   (let* ((event (binary-types:read-binary 'inotify-event stream))
 	 (len (binary-types:read-binary 'binary-types:u32 stream)))
-    (when (> len 0)
+    (when (plusp len)
       (with-slots (name) event
-	(setf name
-	      (binary-types:read-binary-string stream :size len :terminators '(0)))))
+	(setf name (binary-types:read-binary-string stream
+						    :size len
+						    :terminators '(0)))))
     event))
 
-(defun inotify-read-event (stream)
-  (let ((event (inotify-read-raw-event stream)))
+(defun read-event-from-stream (stream)
+  "Reads a event from the inotify stream and converts bitmasks on reading."
+  (let ((event (read-raw-event stream)))
     (with-slots (mask) event
-      (setf mask (foreign-bitfield-symbols 'inotify-flags mask)))
+      (setf mask (foreign-bitfield-symbols 'inotify-flag mask)))
     event))
 
-(defun make-notify ()
-  (let* ((fd (inotify-init)))
-    (when (< fd 0)
-      (error "inotify_init failed: ~A" fd))
-    ;; file descriptor is collected with auto-close
-    (make-inotify-instance
-     fd
-     (sb-sys:make-fd-stream fd
-			    :input T
-			    :element-type '(unsigned-byte 8)
-			    :name (format NIL "inotify event queue ~A" fd)
-			    :auto-close T))))
+(defun set-nonblocking (fd nonblocking)
+  (let ((flags (sb-posix:fcntl fd sb-posix:f-getfl)))
+    ;; an error is raised if this fails, so we don't have to do it ourselves
+    (sb-posix:fcntl fd sb-posix:f-setfl
+		    (funcall (if nonblocking #'logior #'logxor)
+			     flags sb-posix:o-nonblock))))
+
+(defun init-unregistered-notify (notify &optional (nonblocking T))
+  "Creates a new inotify event queue.  If NONBLOCKING is set (default),
+the file descriptor is set to non-blocking I/O."
+  (let ((result (c-inotify-init)))
+    (when (minusp result)
+      (error "inotify_init failed: ~A" result))
+    (with-slots (fd stream (non-block nonblocking)) notify
+      (unwind-protect
+	   ;; file descriptor is collected with auto-close
+	   (progn
+	     (setf fd result)
+	     (when nonblocking
+	       (set-nonblocking fd T)
+	       (setf non-block nonblocking))
+	     (setf stream
+		   (sb-sys:make-fd-stream
+		    fd
+		    :input T
+		    :element-type '(unsigned-byte 8)
+		    :name (format NIL "inotify event queue ~A" fd)
+		    :auto-close T
+		    :buffering (if nonblocking :none :full))))
+	;; if stream is constructed, gc'ing it will cleanup the file descriptor
+	(unless stream
+	  (sb-posix:close fd)))))
+  notify)
+
+(defun make-unregistered-notify ()
+  (init-unregistered-notify (make-inotify-instance)))
 
 (defun close-notify (notify)
-  (close (inotify-instance-stream notify))
+  "Closes the inotify event queue."
+  (close (inotify-stream notify))
   (values))
 
-(defun watch (notify pathname flags)
+(defun watch-raw (notify pathname flags)
+  "Adds PATHNAME (either pathname or string) to be watched.  FLAGS
+determines how exactly (see inotify(7) for detailed information).
+Returns a handle which can be used with UNWATCH."
   (let ((path (princ-to-string pathname))
 	result)
-    (setf result
-	  (inotify-add-watch (inotify-instance-fd notify)
-			     path
-			     (if (listp flags)
-				 (foreign-bitfield-value 'inotify-flags flags)
-				 flags)))
-    (when (< result 0)
+    (setf result (c-inotify-add-watch
+		  (inotify-fd notify)
+		  path
+		  (typecase flags
+		    (list (foreign-bitfield-value 'inotify-flag flags))
+		    (keyword (foreign-bitfield-value 'inotify-flag
+						     (list flags)))
+		    (T flags))))
+    (when (minusp result)
       (error "inotify_add_watch failed: ~A" result))
     result))
 
-(defun unwatch (notify handle)
-  (let ((result (inotify-rm-watch (inotify-instance-fd notify) handle)))
-    (when (< result 0)
-      (error "inotify_rm_watch failed: ~A" result))
-    (values)))
+(defun unwatch-raw (notify handle)
+  "Disables watching the path associated with HANDLE."
+  (let ((result (c-inotify-rm-watch (inotify-fd notify) handle)))
+    (when (minusp result)
+      (error "inotify_rm_watch failed: ~A" result)))
+  (values))
+
+;;;; support functions, making life easier
+
+(defstruct (registered-inotify-instance
+	     (:include inotify-instance)
+	     (:constructor make-registered-inotify-instance ())
+	     (:conc-name inotify-))
+  "Additionally to the information in INOTIFY-INSTANCE, records watched
+paths in a dictionary."
+  watched)
+
+(defun make-notify (&optional (nonblocking T))
+  (let ((result (make-registered-inotify-instance)))
+    (init-unregistered-notify result nonblocking)
+    (with-slots (watched) result
+      (setf watched (make-hash-table :test 'equal)))
+    result))
+
+(defun watchedp (notify pathname)
+  "Returns the tuple (HANDLE . FLAGS) if PATHNAME is being watched by NOTIFY,
+else NIL."
+  (awhen (gethash pathname (inotify-watched notify))
+    (values (car it) (cdr it))))
+
+;; TODO: handle additional flags, save only list of flags
+(defun watch (notify pathname flags)
+  (let ((handle (watch-raw notify pathname flags)))
+    (with-slots (watched) notify
+      (setf (gethash pathname watched) (cons handle flags)))
+    handle))
+
+(defun unwatch (notify &key pathname handle)
+  (unless (or pathname handle)
+    (error "either PATHNAME or HANDLE has to be specified"))
+  (if handle
+      (unwatch-raw notify handle)
+      (let ((handle (watchedp notify pathname)))
+	(unless handle
+	  (error "PATHNAME ~S isn't being watched" pathname))
+	(unwatch-raw notify handle)
+	(remhash pathname (inotify-watched notify))))
+  (values))
+
+(defun list-watched (notify)
+  "Returns a list of all watched pathnames in particular order."
+  (let (result)
+    (maphash (lambda (k v)
+	       (declare (ignore v))
+	       (push k result))
+	     (inotify-watched notify))
+    result))
+
+(defun unix-eagainp (fd-stream)
+  "Returns T on a FD-STREAM, if trying to read raised a EAGAIN error."
+  (multiple-value-bind (result error)
+      (sb-unix:unix-read (sb-sys:fd-stream-fd fd-stream) NIL 0)
+    (declare (ignore result))
+    (= error sb-unix:eagain)))
+
+(defun event-availablep (notify)
+  "Returns T if an event is available on the queue."
+  (if (inotify-nonblocking notify)
+      (not (unix-eagainp (inotify-stream notify)))
+      (listen (inotify-stream notify))))
+
+(defun read-event (notify)
+  "Reads an event from the queue.  Blocks if no event is available."
+  (read-event-from-stream (inotify-stream notify)))
+
+(defun next-event (notify)
+  "Reads an event from the queue.  Returns NIL if none is available."
+  (when (event-availablep notify)
+    (read-event notify)))
+
+(defmacro! do-events ((var o!notify) &body body)
+  "Loops BODY with VAR bound to the events retrieved from NOTIFY.  The macro
+uses NEXT-EVENT, so that reading an event won't block."
+  `(loop as ,var = (next-event ,g!notify)
+      while ,var
+      do (progn ,.body)))
+
+(defun next-events (notify)
+  "Reads all available events from the queue.  Returns a list of events."
+  (let (result)
+   (do-events (event notify)
+     (push event result))
+   (nreverse result)))
diff --git a/package.lisp b/package.lisp
index 4ec662d..0f7b202 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,17 +1,32 @@
 (in-package #:cl-user)
 
 (defpackage cl-notify
-  (:use #:cl #:cffi)
-  (:export #:inotify-event
-	   #:inotify-event-wd
-	   #:inotify-event-mask
-	   #:inotify-event-cookie
-	   #:inotify-event-name
+  (:use #:cl #:cffi #:utils-frahm #:anaphora)
+  (:export ;;; used types for documentation
+	   #:inotify-add/read-flag
+	   #:inotify-read-flag
+	   #:inotify-add-flag
 
-	   #:inotify-read-raw-event
-	   #:inotify-read-event
-	   #:make-inotify
 	   #:close-notify
+
+	   ;;; event parsing functions
+	   #:make-unregistered-notify
+	   #:read-raw-event
+	   #:watch-raw
+	   #:unwatch-raw
+
+	   ;;; enhanced functionality
+	   #:make-notify
+	   #:watchedp
 	   #:watch
 	   #:unwatch
-	   ))
+	   #:event-availablep
+	   #:read-event
+	   #:next-event
+
+	   ;;; convenience functions
+	   #:list-watched
+	   #:do-events
+	   #:read-events
+	   )
+  (:documentation "A binding for the LINUX inotify(7) API."))
-- 
1.7.10.4