Add inotify_init1 variant.
[cl-inotify.git] / inotify.lisp
index 0d9ca13..d768cb5 100644 (file)
@@ -1,31 +1,37 @@
 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-inotify; -*-
 
-;; Copyright (c) 2011, Olof-Joachim Frahm
+;; Copyright (c) 2011-12, Olof-Joachim Frahm
 ;; All rights reserved.
 
 ;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;     * Redistributions of source code must retain the above copyright
-;;       notice, this list of conditions and the following disclaimer.
-;;     * Redistributions in binary form must reproduce the above copyright
-;;       notice, this list of conditions and the following disclaimer in the
-;;       documentation and/or other materials provided with the distribution.
-;;     * The name of the author may not be used to endorse or promote products
-;;       derived from this software without specific prior written permission.
-
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-;; ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
-;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
-;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; modification, are permitted provided that the following conditions
+;; are met:
+
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (in-package #:cl-inotify)
 
+(defbitfield (inotify1-flag :int)
+  (:cloexec       #.in-cloexec)
+  (:nonblock      #.in-nonblock))
+
 (defbitfield (inotify-flag :uint32)
   (:access        #.in-access)
   (:modify        #.in-modify)
@@ -54,7 +60,7 @@
 (deftype inotify-add/read-flag ()
   "Shared valid flags for the WATCH-RAW and READ-EVENT functions."
   '(member
-    :access :attrib 
+    :access :attrib
     :close-write :close-nowrite :close
     :create :delete :delete-self
     :modify
@@ -116,8 +122,8 @@ NAME optionally identifies a file relative to a watched directory."
   (name NIL))
 
 (defstruct (inotify-instance
-            (:constructor make-inotify-instance ())
-            (:conc-name inotify-))
+             (:constructor make-inotify-instance ())
+             (:conc-name inotify-))
   "Contains the stream and file descriptor for a inotify instance."
   fd
   stream
@@ -128,24 +134,25 @@ NAME optionally identifies a file relative to a watched directory."
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun read-new-value (&optional (stream *query-io*))
     "READs a value from the STREAM and returns it (wrapped in a list)."
-    (format stream "Enter a new value: ~%")
-    (list (read *query-io*))))
+    (format stream "~&Enter a new value (unevaluated): ")
+    (force-output stream)
+    (list (read stream))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun init-endian ()
     "Initialises the endianess for the BINARY-TYPES library.  Is automatically
 called when the library is loaded."
     (setf binary-types:*endian*
-         (restart-case #+little-endian :little-endian
-                       #+big-endian :big-endian
-                       #-(or little-endian big-endian) (error "unknown endianess")
-                       (use-value (value)
-                         :report "Enter a correct value (either :LITTLE-ENDIAN or :BIG-ENDIAN)."
-                         :interactive read-new-value
-                         ;; TODO: better way to test for correct value/retry values?
-                         (case value
-                           ((:little-endian :big-endian) value)
-                           (T (error "wrong value supplied (not :LITTLE-ENDIAN or :BIG-ENDIAN)"))))))))
+          (restart-case #+little-endian :little-endian
+                        #+big-endian :big-endian
+                        #-(or little-endian big-endian) (error "unknown endianess")
+                        (use-value (value)
+                          :report "Enter a correct value (either :LITTLE-ENDIAN or :BIG-ENDIAN)."
+                          :interactive read-new-value
+                          ;; TODO: better way to test for correct value/retry values?
+                          (case value
+                            ((:little-endian :big-endian) value)
+                            (T (error "wrong value supplied (not :LITTLE-ENDIAN or :BIG-ENDIAN)"))))))))
 
 ;; initialise the endianess
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -156,12 +163,12 @@ called when the library is loaded."
 (defun read-raw-event-from-stream (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)))
+         (len (binary-types:read-binary 'binary-types:u32 stream)))
     (when (plusp len)
       (with-slots (name) event
-       (let ((buffer (make-array len :element-type '(unsigned-byte 8))))
-         (read-sequence buffer stream :end len)
-         (setf name (trivial-utf-8:utf-8-bytes-to-string buffer :end (position 0 buffer))))))
+        (let ((buffer (make-array len :element-type '(unsigned-byte 8))))
+          (read-sequence buffer stream :end len)
+          (setf name (trivial-utf-8:utf-8-bytes-to-string buffer :end (position 0 buffer))))))
     event))
 
 (defun read-event-from-stream (stream)
@@ -176,8 +183,8 @@ called when the library is loaded."
   (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)))
+                    (funcall (if nonblocking #'logior #'logxor)
+                             flags sb-posix:o-nonblock)))
   (values))
 
 (defun init-unregistered-inotify (inotify &optional (nonblocking T))
@@ -188,28 +195,28 @@ the file descriptor is set to non-blocking I/O."
       (perror "inotify_init failed"))
     (with-slots (fd stream (non-block nonblocking)) inotify
       (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)))))
+           ;; 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)))))
   inotify)
 
-(defun make-unregistered-inotify ()
+(defun make-unregistered-inotify (&optional (nonblocking T))
   "Creates a new unregistered INOTIFY instance."
-  (init-unregistered-inotify (make-inotify-instance)))
+  (init-unregistered-inotify (make-inotify-instance) nonblocking))
 
 (defun close-inotify (inotify)
   "Closes the inotify event queue."
@@ -235,10 +242,10 @@ determines how exactly (see inotify(7) for detailed information) and can
 be of type LIST, KEYWORD or a raw numerical value (which isn't checked
 for validity though).  Returns a handle which can be used with UNWATCH-RAW."
   (let* ((path (etypecase pathname
-                (string pathname)
-                (pathname (namestring pathname))))
-        (result (c-inotify-add-watch (inotify-fd inotify)
-                                     path (translate-keyword-flags flags))))
+                 (string pathname)
+                 (pathname (namestring pathname))))
+         (result (c-inotify-add-watch (inotify-fd inotify)
+                                      path (translate-keyword-flags flags))))
     (when (minusp result)
       (perror "inotify_add_watch failed"))
     result))
@@ -253,9 +260,9 @@ for validity though).  Returns a handle which can be used with UNWATCH-RAW."
 ;;;; support functions, making life easier
 
 (defstruct (registered-inotify-instance
-            (:include inotify-instance)
-            (:constructor make-registered-inotify-instance ())
-            (:conc-name inotify-))
+             (: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)
@@ -280,22 +287,22 @@ being watched by INOTIFY, else NIL.  The match is exact."
 registration.  If HANDLE is specified EVENT is ignored."
   (block NIL
     (maphash (lambda (pathname entry)
-              (when (eql (car entry) handle)
-                (return (values pathname (cdr entry)))))
-            (inotify-watched inotify))))
+               (when (eql (car entry) handle)
+                 (return (values pathname (cdr entry)))))
+             (inotify-watched inotify))))
 
 (defun sane-user-flags (inotify pathname flags &key (replace-p T))
   (check-type flags watch-flag-list)
   ;; now, :mask-add can't be member of flags
   ;; merge the flags
   (let* ((flags (ensure-list flags))
-        (rep-flags (if replace-p
-                       (cons :mask-add flags)
-                       flags)))
+         (rep-flags (if replace-p
+                        (cons :mask-add flags)
+                        flags)))
     (let ((it (gethash pathname (slot-value inotify 'watched))))
       (if it
-         (union (cdr it) rep-flags :test #'eq)
-         rep-flags))))
+          (union (cdr it) rep-flags :test #'eq)
+          rep-flags))))
 
 (defun watch (inotify pathname flags &key (replace-p T))
   "Adds PATHNAME (either pathname or string) to be watched and records the
@@ -305,7 +312,7 @@ with UNWATCH and EVENT-PATHNAME/FLAGS.  If REPLACE-P is set to T (default),
 the flags mask is replaced rather than OR-ed to the current mask (if it
 exists).  The :MASK-ADD flag is therefore removed from the FLAGS argument."
   (let* ((flags (sane-user-flags inotify pathname flags :replace-p replace-p))
-        (handle (watch-raw inotify pathname flags)))
+         (handle (watch-raw inotify pathname flags)))
     (with-slots (watched) inotify
       (setf (gethash pathname watched) (cons handle flags)))
     handle))
@@ -320,18 +327,18 @@ may be one from a given EVENT) or PATHNAME."
   (if handle
       (unwatch-raw inotify handle)
       (let ((handle (car (pathname-handle/flags inotify pathname))))
-       (unless handle
-         (error "PATHNAME ~S isn't being watched" pathname))
-       ;; remove even if unwatch-raw throws an error (which can happen if :oneshot is specified)
-       (remhash pathname (inotify-watched inotify))
-       (unwatch-raw inotify handle)))
+        (unless handle
+          (error "PATHNAME ~S isn't being watched" pathname))
+        ;; remove even if unwatch-raw throws an error (which can happen if :oneshot is specified)
+        (remhash pathname (inotify-watched inotify))
+        (unwatch-raw inotify handle)))
   (values))
 
 (defun list-watched (inotify)
   "Returns a LIST of all watched pathnames in no particular order."
   (loop
-     for pathname being each hash-key in (inotify-watched inotify)
-     collect pathname))
+    for pathname being each hash-key in (inotify-watched inotify)
+    collect pathname))
 
 (defun unix-eagain-p (fd-stream)
   "Returns T on a FD-STREAM if trying to read from the stream raised a
@@ -363,15 +370,137 @@ terminates if no events are available."
   (check-type var symbol)
   (let ((inotify-sym (gensym)))
    `(loop
-       with ,var and ,inotify-sym = ,inotify
-       ,.(unless blocking-p
-          `(while (event-available-p ,inotify-sym)))
-       do (progn
-           (setf ,var (read-event ,inotify-sym))
-           ,.body))))
+      with ,var and ,inotify-sym = ,inotify
+      ,.(unless blocking-p
+          `(while (event-available-p ,inotify-sym)))
+      do (progn
+           (setf ,var (read-event ,inotify-sym))
+           ,@body))))
 
 (defun next-events (inotify)
   "Reads all available events from the queue.  Returns a LIST of events."
   (loop
-     while (event-available-p inotify)
-     collect (read-event inotify)))
+    while (event-available-p inotify)
+    collect (read-event inotify)))
+
+;;; this has the longer name, because this way you actually have to read
+;;; about the differences, at least i hope so
+(defmacro with-unregistered-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
+  "Like WITH-INOTIFY, but uses MAKE-UNREGISTERED-INOTIFY and WATCH-RAW
+instead.  Useful if you need to monitor just a fixed set of paths."
+  `(let* ((,inotify (make-unregistered-inotify ,nonblocking)))
+     (unwind-protect
+          (progn
+            ,.(mapcar (lambda (specifier)
+                        `(watch-raw ,inotify ,@specifier))
+                      rest)
+            ,@body)
+       (close-inotify ,inotify))))
+
+(defmacro with-inotify ((inotify &optional (nonblocking T) &rest rest) &body body)
+  "Executes BODY with a newly created queue bound to INOTIFY if true.
+See MAKE-INOTIFY for more information about possible arguments.
+
+The REST is a list of argument forms for the WATCH function, i.e. one or
+more forms (PATHNAME FLAGS &KEY (REPLACE-P T)).
+
+Since the QUEUE is closed on unwinding, this macro doesn't bother with
+UNWATCH calls on all WATCHed paths."
+  `(let* ((,inotify (make-inotify ,nonblocking)))
+     (unwind-protect
+          (progn
+            ,.(mapcar (lambda (specifier)
+                        `(watch ,inotify ,@specifier))
+                      rest)
+            ,@body)
+       (close-inotify ,inotify))))
+
+;; TODO: what about other implementations?
+#+sbcl
+(defmacro with-inotify-event-handler ((inotify
+                                       &optional (nonblocking T) (registered T)
+                                       &rest rest)
+                                      event-handler
+                                      &body body)
+  "Registers an INOTIFY queue and runs EVENT-HANDLER with it as only
+parameter whenever input happens while the BODY is executed.
+
+Other parameters are passed to WITH-(UNREGISTERED)-INOTIFY depending on the
+value of REGISTERED (default T)."
+  (let ((handle (gensym "HANDLE")))
+    `(,(if registered 'with-inotify 'with-unregistered-inotify)
+      (,inotify ,nonblocking ,@rest)
+      (sb-sys:with-fd-handler
+          ((inotify-fd ,inotify)
+           :input
+           (lambda (,handle)
+             (declare (ignore ,handle))
+             (funcall ,event-handler ,inotify)))
+          ,@body))))
+
+(defun run-inotify-program (program args rest directories flags
+                            &key function (wait T) event-handler (registered T))
+  "Runs a program and records all matched events in all DIRECTORIES using
+FLAGS.  If EVENT-HANDLER is set, it is instead called with every available
+event.
+
+PROGRAM, ARGS and REST are the arguments to SB-EXT:RUN-PROGRAM.  REST is
+passed on verbatim except for the WAIT parameter, which is set to false.
+
+PROGRAM may also be a FUNCTION, in which case it is called with
+\(ARGS . REST) as arguments and has to return a process object like from
+SB-EXT:RUN-PROGRAM.  The process also shouldn't be spawned with WAIT set.
+
+DIRECTORIES is a list of directory arguments for WATCH/-RAW.
+
+WAIT is only valid if FUNCTION is set.  If it is true, after FUNCTION has
+returned, we wait until the process has quit.
+
+On supported implementations (SBCL) the FUNCTION parameter may be used to
+do some work while the program is running and watched by the inotify queue.
+It is called with the process object and the inotify queue as arguments."
+  (let (events)
+    (labels ((run ()
+               (typecase program
+                 (function (apply program args rest))
+                 (T
+                  (apply #'sb-ext:run-program program args :wait NIL rest))))
+             (events (inotify)
+               (do-events (event inotify)
+                 (if event-handler
+                     (funcall event-handler event)
+                     (push event events))))
+             (body (inotify)
+               (unwind-protect
+                    (progn
+                      (let ((register (if registered #'watch #'watch-raw)))
+                        (mapcar (lambda (directory)
+                                  (funcall register inotify directory flags))
+                                directories))
+                      (let ((process (run)))
+                        (if function
+                            (unwind-protect
+                                 (funcall function process inotify)
+                              ;; wait in any case so catching the files will work
+                              (when wait
+                                (sb-ext:process-wait process)))
+                            (loop
+                              while (sb-ext:process-alive-p process)
+                              do (events inotify)
+                              finally (return (if event-handler
+                                                  process
+                                                  (values (nreverse events) process)))))))
+                 (close-inotify inotify))))
+      (let ((inotify (if registered (make-inotify) (make-unregistered-inotify))))
+        (if function
+            #-sbcl
+            (error "the FUNCTION parameter is only supported on SBCL for now")
+            #+sbcl
+            (sb-sys:with-fd-handler
+                ((inotify-fd inotify)
+                 :input
+                 (lambda (handle)
+                   (declare (ignore handle))
+                   (events inotify)))
+                (body inotify))
+            (body inotify))))))