;;; -*- 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)
(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
(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
(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)
(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)
(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))
(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."
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))
;;;; 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)
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
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))
(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)
`(loop
with ,var and ,inotify-sym = ,inotify
,.(unless blocking-p
- `(while (event-available-p ,inotify-sym)))
+ `(while (event-available-p ,inotify-sym)))
do (progn
- (setf ,var (read-event ,inotify-sym))
- ,.body))))
+ (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)))
+
+;;; 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))))))