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