X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=inotify.lisp;h=d768cb59972debdfdcc0c4c66e362f85f5446866;hb=2a1a0dca724e7008a6c4ec696c1de505168c7561;hp=3ff12d74c7b1e1a86aea4dc8cfea54c99e1a7770;hpb=5d80fe9273977aa7c21f26f3481c013086c0ac53;p=cl-inotify.git diff --git a/inotify.lisp b/inotify.lisp index 3ff12d7..d768cb5 100644 --- a/inotify.lisp +++ b/inotify.lisp @@ -28,6 +28,10 @@ (in-package #:cl-inotify) +(defbitfield (inotify1-flag :int) + (:cloexec #.in-cloexec) + (:nonblock #.in-nonblock)) + (defbitfield (inotify-flag :uint32) (:access #.in-access) (:modify #.in-modify) @@ -56,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 @@ -118,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 @@ -130,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) @@ -158,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) @@ -178,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)) @@ -190,23 +195,23 @@ 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 (&optional (nonblocking T)) @@ -237,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)) @@ -255,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) @@ -282,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 @@ -307,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)) @@ -322,11 +327,11 @@ 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) @@ -367,10 +372,10 @@ terminates if no events are available." `(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." @@ -380,19 +385,19 @@ terminates if no events are available." ;;; 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 ((&optional inotify (nonblocking T) &rest rest) &body body) +(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) + (progn + ,.(mapcar (lambda (specifier) + `(watch-raw ,inotify ,@specifier)) + rest) + ,@body) (close-inotify ,inotify)))) -(defmacro with-inotify ((&optional inotify (nonblocking T) &rest rest) &body body) +(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. @@ -403,9 +408,99 @@ 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) + (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))))))