-;; Copyright (C) 2009 Olof-Joachim Frahm
-
-;; This program is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by the
-;; Free Software Foundation; either version 3 of the License, or (at your
-;; option) any later version.
-
-;; This program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-;; Public License for more details.
-
-;; You should have received a copy of the GNU General Public License along
-;; with this program; if not, see <http://www.gnu.org/licenses/>.
+;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-inotify; -*-
+
+;; 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:
+
+;; 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
- (setf name (binary-types:read-binary-string stream
- :size len
- :terminators '(0)))))
+ (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-notify (notify &optional (nonblocking T))
+(defun init-unregistered-inotify (inotify &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)
(perror "inotify_init failed"))
- (with-slots (fd stream (non-block nonblocking)) notify
+ (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)))))
- notify)
-
-(defun make-unregistered-notify ()
- "Creates a new unregistered NOTIFY instance."
- (init-unregistered-notify (make-inotify-instance)))
-
-(defun close-notify (notify)
+ ;; 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 (&optional (nonblocking T))
+ "Creates a new unregistered INOTIFY instance."
+ (init-unregistered-inotify (make-inotify-instance) nonblocking))
+
+(defun close-inotify (inotify)
"Closes the inotify event queue."
- (close (inotify-stream notify))
+ (close (inotify-stream inotify))
(values))
(defun perror (prefix-string)
(foreign-bitfield-value 'inotify-flag (ensure-list flags)))
(T flags)))
-(defun watch-raw (notify pathname flags)
+(defun watch-raw (inotify pathname flags)
"Adds PATHNAME (either of type PATHNAME or STRING) to be watched. FLAGS
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 notify)
- 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))
-(defun unwatch-raw (notify handle)
+(defun unwatch-raw (inotify handle)
"Stops watching the path associated with a HANDLE established by WATCH-RAW."
- (let ((result (c-inotify-rm-watch (inotify-fd notify) handle)))
+ (let ((result (c-inotify-rm-watch (inotify-fd inotify) handle)))
(when (minusp result)
(perror "inotify_rm_watch failed")))
(values))
;;;; 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)
-(defun make-notify (&optional (nonblocking T))
- "Creates a new registered NOTIFY instance. In NONBLOCKING mode, the file
-descriptor is set to non-blocking mode."
+(defun make-inotify (&optional (nonblocking T))
+ "Creates a new registered INOTIFY instance. In NONBLOCKING mode, the file
+descriptor is set to non-blocking mode. The resulting object has to be
+closed with CLOSE-INOTIFY."
(let ((result (make-registered-inotify-instance)))
- (init-unregistered-notify result nonblocking)
+ (init-unregistered-inotify result nonblocking)
(with-slots (watched) result
(setf watched (make-hash-table :test 'equal)))
result))
-(defun watchedp (notify pathname)
- "Returns two values HANDLE and FLAGS if PATHNAME is being watched by NOTIFY,
-else NIL."
- (let ((it (gethash pathname (inotify-watched notify))))
- (when it (values (car it) (cdr it)))))
-
-(defun sane-user-flags (notify pathname flags &key (replace-p T))
+(defun pathname-handle/flags (inotify pathname)
+ "Returns a CONS cell with the values HANDLE and FLAGS if PATHNAME is
+being watched by INOTIFY, else NIL. The match is exact."
+ (gethash pathname (inotify-watched inotify)))
+
+(defun event-pathname/flags (inotify event &optional (handle (slot-value event 'wd)))
+ "Returns two values PATHNAME and FLAGS for an EVENT which were used during
+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))))
+
+(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)))
- (let ((it (gethash pathname (slot-value notify 'watched))))
+ (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 (notify pathname flags &key (replace-p T))
+(defun watch (inotify pathname flags &key (replace-p T))
"Adds PATHNAME (either pathname or string) to be watched and records the
watched paths. FLAGS (a list of keywords) determines how exactly (see
inotify(7) for detailed information). Returns a handle which can be used
-with UNWATCH. 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 notify pathname flags :replace-p replace-p))
- (handle (watch-raw notify pathname flags)))
- (with-slots (watched) notify
+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)))
+ (with-slots (watched) inotify
(setf (gethash pathname watched) (cons handle flags)))
handle))
-(defun unwatch (notify &key pathname handle)
- "Disables watching the path associated with the supplied HANDLE or PATHNAME."
- (unless (or pathname handle)
- (error "either PATHNAME or HANDLE has to be specified"))
+(defun unwatch (inotify &key pathname event handle)
+ "Disables watching the path associated with the supplied HANDLE (which
+may be one from a given EVENT) or PATHNAME."
+ (unless (or pathname event handle)
+ (error "either PATHNAME, EVENT or HANDLE have to be specified"))
+ (when event
+ (setf handle (slot-value event 'wd)))
(if handle
- (unwatch-raw notify handle)
- (let ((handle (watchedp notify 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 notify))
- (unwatch-raw notify 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)))
(values))
-(defun list-watched (notify)
- "Returns a list of all watched pathnames in no particular order."
+(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 notify)
- 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
(declare (ignore result))
(= error sb-unix:eagain)))
-(defun event-available-p (notify)
+(defun event-available-p (inotify)
"Returns T if an event is available on the queue."
- (if (inotify-nonblocking notify)
- (not (unix-eagain-p (inotify-stream notify)))
- (listen (inotify-stream notify))))
+ (if (inotify-nonblocking inotify)
+ (not (unix-eagain-p (inotify-stream inotify)))
+ (listen (inotify-stream inotify))))
-(defun read-event (notify)
+(defun read-event (inotify)
"Reads an event from the queue. Blocks if no event is available."
- (read-event-from-stream (inotify-stream notify)))
+ (read-event-from-stream (inotify-stream inotify)))
-(defun next-event (notify)
+(defun next-event (inotify)
"Reads an event from the queue. Returns NIL if none is available."
- (when (event-available-p notify)
- (read-event notify)))
+ (when (event-available-p inotify)
+ (read-event inotify)))
-(defmacro do-events ((var notify &key blocking-p) &body body)
- "Loops BODY with VAR bound to the next events retrieved from NOTIFY.
+(defmacro do-events ((var inotify &key blocking-p) &body body)
+ "Loops BODY with VAR bound to the next events retrieved from INOTIFY.
The macro uses NEXT-EVENT, so reading an event won't block and the loop
terminates if no events are available."
(check-type var symbol)
- (let ((notify-sym (gensym)))
+ (let ((inotify-sym (gensym)))
`(loop
- with ,var and ,notify-sym = ,notify
- ,.(unless blocking-p
- `(while (event-available-p ,notify-sym)))
- do (progn
- (setf ,var (read-event ,notify-sym))
- ,.body))))
-
-(defun next-events (notify)
+ 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 notify)
- collect (read-event notify)))
+ 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))))))
projects / cl-inotify.git / blobdiff