Add iolib functions.

[cl-inotify.git] / inotify.lisp

diff --git a/inotify.lisp b/inotify.lisp
index 9277300..8c97386 100644 (file)
--- a/inotify.lisp
+++ b/inotify.lisp
@@ -1,6 +1,6 @@
-;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8; package: cl-inotify; -*-
+;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; 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
 ;; All rights reserved.
 
 ;; Redistribution and use in source and binary forms, with or without

@@ -28,6 +28,15 @@
 
 (in-package #:cl-inotify)
 
 
 (in-package #:cl-inotify)
 

+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (boundp 'in-cloexec)
+    (pushnew 'inotify1 *features*)))
+
+#+cl-inotify::inotify1
+(defbitfield (inotify1-flag :int)
+  (:cloexec       #.in-cloexec)
+  (:nonblock      #.in-nonblock))
+

 (defbitfield (inotify-flag :uint32)
   (:access        #.in-access)
   (:modify        #.in-modify)
 (defbitfield (inotify-flag :uint32)
   (:access        #.in-access)
   (:modify        #.in-modify)

@@ -56,7 +65,7 @@
 (deftype inotify-add/read-flag ()
   "Shared valid flags for the WATCH-RAW and READ-EVENT functions."
   '(member
 (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
     :close-write :close-nowrite :close
     :create :delete :delete-self
     :modify

@@ -90,17 +99,22 @@ thus should be used only with WATCH-RAW)."
   '(or (satisfies valid-watch-flag-p)
        (and list (satisfies valid-watch-flag-list-p))))
 
   '(or (satisfies valid-watch-flag-p)
        (and list (satisfies valid-watch-flag-list-p))))
 

-(defcfun ("inotify_init" c-inotify-init) :int
+(defsyscall inotify-init :int

   "Initialises a new inotify event queue.")
 
   "Initialises a new inotify event queue.")
 

-(defcfun ("inotify_add_watch" c-inotify-add-watch) :int
-  "Watches a path on a event queue."
+#+cl-inotify::inotify1
+(defsyscall inotify-init1 :int
+  "Initialises a new inotify event queue and passes some flags along."
+  (flags inotify1-flag))
+
+(defsyscall inotify-add-watch :int
+  "Watches a path on an event queue."

   (fd :int)
   (pathname :string)
   (mask inotify-flag))
 
   (fd :int)
   (pathname :string)
   (mask inotify-flag))
 

-(defcfun ("inotify_rm_watch" c-inotify-rm-watch) :int
-  "Removes a watched path from a event queue."
+(defsyscall inotify-rm-watch :int
+  "Removes a watched path from an event queue."

   (fd :int)
   (wd :int))
 
   (fd :int)
   (wd :int))
 

@@ -118,8 +132,8 @@ NAME optionally identifies a file relative to a watched directory."
   (name NIL))
 
 (defstruct (inotify-instance
   (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
   "Contains the stream and file descriptor for a inotify instance."
   fd
   stream

@@ -130,24 +144,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)."
 (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*
 
 (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)
 
 ;; initialise the endianess
 (eval-when (:compile-toplevel :load-toplevel :execute)

@@ -158,12 +173,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))
 (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
     (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)
     event))
 
 (defun read-event-from-stream (stream)

@@ -175,53 +190,65 @@ called when the library is loaded."
 
 (defun set-nonblocking (fd nonblocking)
   "Enables or disables NONBLOCKING mode on a file descriptor FD."
 
 (defun set-nonblocking (fd nonblocking)
   "Enables or disables NONBLOCKING mode on a file descriptor FD."

-  (let ((flags (sb-posix:fcntl fd sb-posix:f-getfl)))
+  (let ((flags (osicat-posix:fcntl fd osicat-posix:f-getfl)))

     ;; an error is raised if this fails, so we don't have to do it ourselves
     ;; 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)))
+    (osicat-posix:fcntl fd osicat-posix:f-setfl
+                        (funcall (if nonblocking #'logior #'logxor)
+                                 flags osicat-posix:o-nonblock)))

   (values))
 
 (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."
   (values))
 
 (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)) 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)))))
+  (with-slots (fd stream (non-block nonblocking)) inotify
+    (unwind-protect
+         ;; file descriptor is collected with auto-close
+         (progn
+           (setf non-block nonblocking)
+           #+inotify1
+           (setf fd (inotify-init1 (and non-block :nonblock)))
+           #-inotify1
+           (setf fd (inotify-init))
+           #-inotify1
+           (when non-block
+             (set-nonblocking fd T))
+           (setf stream
+                 ;; TODO: what about the blocking?
+                 #-(or clisp sbcl)
+                 (osicat::make-fd-stream
+                  fd
+                  :direction :input
+                  :element-type '(unsigned-byte 8))
+                 #+clisp
+                 (ext:make-stream
+                  fd
+                  :direction :input
+                  :element-type '(unsigned-byte 8)
+                  :buffered (not nonblocking))
+                 #+sbcl
+                 (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
+      ;; TODO: is this true for clisp?  because the docs say that
+      ;; EXT:MAKE-STREAM uses dup(2)
+      (unless stream
+        (osicat-posix:close fd))))

   inotify)
 
   inotify)
 

-(defun make-unregistered-inotify ()
+(defun make-unregistered-inotify (&optional (nonblocking T))

   "Creates a new unregistered INOTIFY instance."
   "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."
   (close (inotify-stream inotify))
   (values))
 
 
 (defun close-inotify (inotify)
   "Closes the inotify event queue."
   (close (inotify-stream inotify))
   (values))
 

-(defun perror (prefix-string)
-  #+sbcl (sb-int:simple-perror prefix-string)
-  #-(or sbcl) (error prefix-string))
-

 (defun ensure-list (arg)
   (if (listp arg) arg `(,arg)))
 
 (defun ensure-list (arg)
   (if (listp arg) arg `(,arg)))
 

@@ -237,27 +264,22 @@ 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
 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))))
-    (when (minusp result)
-      (perror "inotify_add_watch failed"))
-    result))
+                 (string pathname)
+                 (pathname (namestring pathname)))))
+    (inotify-add-watch (inotify-fd inotify)
+                       path (translate-keyword-flags flags))))

 
 (defun unwatch-raw (inotify handle)
   "Stops watching the path associated with a HANDLE established by WATCH-RAW."
 
 (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 inotify) handle)))
-    (when (minusp result)
-      (perror "inotify_rm_watch failed")))
+  (inotify-rm-watch (inotify-fd inotify) handle)

   (values))
 
 ;;;; support functions, making life easier
 
 (defstruct (registered-inotify-instance
   (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)
   "Additionally to the information in INOTIFY-INSTANCE, records watched
 paths in a dictionary."
   watched)

@@ -282,22 +304,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)
 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))
 
 (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
     (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
 
 (defun watch (inotify pathname flags &key (replace-p T))
   "Adds PATHNAME (either pathname or string) to be watched and records the

@@ -307,7 +329,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))
 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))
     (with-slots (watched) inotify
       (setf (gethash pathname watched) (cons handle flags)))
     handle))

@@ -322,11 +344,11 @@ may be one from a given EVENT) or PATHNAME."
   (if handle
       (unwatch-raw inotify handle)
       (let ((handle (car (pathname-handle/flags inotify 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)
   (values))
 
 (defun list-watched (inotify)

@@ -335,18 +357,21 @@ may be one from a given EVENT) or PATHNAME."
     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
-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 unix-eagain-p (fd)
+  "Returns T on a file descriptor if trying to read raised an EAGAIN
+error."
+  (handler-case (prog1 NIL (osicat-posix:read fd (null-pointer) 0))
+    ;; we have to check for both to be portable, says read(2)
+    (osicat-posix:eagain () T)
+    (osicat-posix:ewouldblock () T)
+    ;; this is set if the kernel is newer than 2.6.21 if the buffer is
+    ;; too small to get the next event (which it certainly is)
+    (osicat-posix:einval () NIL)))

 
 (defun event-available-p (inotify)
   "Returns T if an event is available on the queue."
   (if (inotify-nonblocking inotify)
 
 (defun event-available-p (inotify)
   "Returns T if an event is available on the queue."
   (if (inotify-nonblocking inotify)

-      (not (unix-eagain-p (inotify-stream inotify)))
+      (not (unix-eagain-p (inotify-fd inotify)))

       (listen (inotify-stream inotify))))
 
 (defun read-event (inotify)
       (listen (inotify-stream inotify))))
 
 (defun read-event (inotify)

@@ -361,19 +386,55 @@ EAGAIN error."
 (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
 (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."
+terminates if no events are available.  If BLOCKING-P is set, the loop
+blocks if no events are available, otherwise it exits as soon as no
+events were encountered."

   (check-type var symbol)
   (let ((inotify-sym (gensym)))
    `(loop
       with ,var and ,inotify-sym = ,inotify
       ,.(unless blocking-p
   (check-type var symbol)
   (let ((inotify-sym (gensym)))
    `(loop
       with ,var and ,inotify-sym = ,inotify
       ,.(unless blocking-p

-         `(while (event-available-p ,inotify-sym)))
+          `(while (event-available-p ,inotify-sym)))

       do (progn
       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)))
 
 (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)
+            (values)
+            ,@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)
+            (values)
+            ,@body)
+       (close-inotify ,inotify))))