io.streams/zeta/ffi-functions-unix.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- *NIX-specific routines.
   4 ;;;
   5
   6 (in-package :io.zeta-streams)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; FD polling
  10 ;;;-------------------------------------------------------------------------
  11
  12 (defun compute-poll-flags (type)
  13   (ecase type
  14     (:input  (logior pollin pollrdhup pollpri))
  15     (:output (logior pollout))
  16     (:io     (logior pollin pollrdhup pollpri pollout))))
  17
  18 (defun process-poll-revents (fd event-type revents)
  19   (flet ((poll-error ()
  20            (error 'poll-error :code ebadf :identifier :ebadf
  21                   :event-type event-type :os-handle fd
  22                   :message "invalid OS handle")))
  23     (let ((readp  nil) (rhupp nil)
  24           (writep nil) (whupp nil))
  25       (flags-case revents
  26         ((pollin pollpri)   (setf readp t))
  27         ((pollrdhup)        (setf rhupp t))
  28         ((pollout)          (setf writep t))
  29         ((pollhup)          (setf whupp t))
  30         ((pollerr pollnval) (poll-error)))
  31       (values readp rhupp writep whupp))))
  32
  33 (defun timeout->milisec (timeout)
  34   (multiple-value-bind (sec usec)
  35       (decode-timeout timeout)
  36     (+ (* sec 1000) (truncate usec 1000))))
  37
  38 (defun %poll (fds timeout)
  39   (repeat-upon-condition-decreasing-timeout
  40       ((eintr) remaining-time timeout)
  41     (%sys-poll fds 1 (timeout->milisec remaining-time))))
  42
  43 (defun poll-fd (file-descriptor event-type timeout)
  44   "Poll file descriptor `FD' for I/O readiness. `EVENT-TYPE' must be either
  45 :INPUT, :OUTPUT or :IO. `TIMEOUT' must be a non-negative real measured
  46 in seconds. If a timeout occurs `POLL-TIMEOUT' is signaled.
  47 Returns two boolean values indicating readability and writeability of `FD'."
  48   (flet ((poll-error (posix-err)
  49            (error 'poll-error
  50                   :code (posix-file-error-code posix-err)
  51                   :identifier (posix-file-error-identifier posix-err)
  52                   :event-type event-type
  53                   :os-handle file-descriptor
  54                   :message (format nil "OS error ~A"
  55                                    (posix-file-error-identifier posix-err)))))
  56     (with-foreign-object (pollfd 'pollfd)
  57       (%sys-bzero pollfd size-of-pollfd)
  58       (with-foreign-slots ((fd events revents) pollfd pollfd)
  59         (setf fd file-descriptor
  60               events (compute-poll-flags event-type))
  61         (handler-case
  62             (cond
  63               ((plusp (%poll pollfd timeout))
  64                (process-poll-revents fd event-type revents))
  65               (t
  66                (error 'poll-timeout
  67                       :os-handle file-descriptor
  68                       :event-type event-type)))
  69           (posix-error (err) (poll-error err)))))))
  70 \f
  71
  72 ;;;-------------------------------------------------------------------------
  73 ;;; Set FD nonblocking
  74 ;;;-------------------------------------------------------------------------
  75
  76 (defun %set-fd-nonblock (fd)
  77   (declare (special *device*))
  78   (handler-case
  79       (with-foreign-object (arg :int)
  80         (setf (mem-aref arg :int) 1)
  81         (%sys-ioctl/3 fd fionbio arg))
  82     (posix-error (err)
  83       (posix-file-error err *device* "issuing FIONBIO IOCTL on")))
  84   (values))
  85 \f
  86
  87 ;;;-------------------------------------------------------------------------
  88 ;;; Get number of bytes availabe on FD
  89 ;;;-------------------------------------------------------------------------
  90
  91 (defun %get-fd-nbytes (fd)
  92   (declare (special *device*))
  93   (handler-case
  94       (with-foreign-object (arg :int)
  95         (%sys-ioctl/3 fd fionread arg)
  96         (mem-aref arg :int))
  97     (posix-error (err)
  98       (posix-file-error err *device* "issuing FIONREAD IOCTL on"))))
  99 \f
 100
 101 ;;;-------------------------------------------------------------------------
 102 ;;; File Descriptor reading
 103 ;;;-------------------------------------------------------------------------
 104
 105 (defun %read-octets/non-blocking (fd vector start end)
 106   (declare (type ub8-simple-vector vector)
 107            (special *device*))
 108   (with-pointer-to-vector-data (buf vector)
 109     (handler-case
 110         (%sys-read fd (inc-pointer buf start) (- end start))
 111       (ewouldblock () 0)
 112       (posix-error (err)
 113         (posix-file-error err *device* "reading data from"))
 114       (:no-error (nbytes)
 115         (if (zerop nbytes) :eof nbytes)))))
 116
 117 (defun %read-octets/timeout (fd vector start end timeout)
 118   (declare (type ub8-simple-vector vector)
 119            (special *device*))
 120   (with-pointer-to-vector-data (buf vector)
 121     (repeat-decreasing-timeout (remaining (clamp-timeout timeout) :rloop)
 122       (flet ((check-timeout ()
 123                (if (plusp remaining)
 124                    (poll-fd fd :input remaining)
 125                    (return-from :rloop 0))))
 126         (handler-case
 127             (%sys-read fd (inc-pointer buf start) (- end start))
 128           (ewouldblock () (check-timeout))
 129           (posix-error (err)
 130             (posix-file-error err *device* "reading data from"))
 131           (:no-error (nbytes)
 132             (return-from :rloop
 133               (if (zerop nbytes) :eof nbytes))))))))
 134 \f
 135
 136 ;;;-------------------------------------------------------------------------
 137 ;;; File Descriptor writing
 138 ;;;-------------------------------------------------------------------------
 139
 140 (defun %write-octets/non-blocking (fd vector start end)
 141   (declare (type ub8-simple-vector vector)
 142            (special *device*))
 143   (with-pointer-to-vector-data (buf vector)
 144     (handler-case
 145         (%sys-write fd (inc-pointer buf start) (- end start))
 146       (ewouldblock () 0)
 147       (epipe () :hangup)
 148       (posix-error (err)
 149         (posix-file-error err *device* "writing data to"))
 150       (:no-error (nbytes)
 151         (if (zerop nbytes) :hangup nbytes)))))
 152
 153 (defun %write-octets/timeout (fd vector start end timeout)
 154   (declare (type ub8-simple-vector vector)
 155            (special *device*))
 156   (with-pointer-to-vector-data (buf vector)
 157     (repeat-decreasing-timeout (remaining (clamp-timeout timeout) :rloop)
 158       (flet ((check-timeout ()
 159                (if (plusp remaining)
 160                    (poll-fd fd :output remaining)
 161                    (return-from :rloop 0))))
 162         (handler-case
 163             (%sys-write fd (inc-pointer buf start) (- end start))
 164           (ewouldblock () (check-timeout))
 165           (epipe () (return-from :rloop :hangup))
 166           (posix-error (err)
 167             (posix-file-error err *device* "writing data to"))
 168           (:no-error (nbytes)
 169             (return-from :rloop
 170               (if (zerop nbytes) :hangup nbytes))))))))