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            (special *device*))
  98   (with-pointer-to-vector-data (buf vector)
  99     (handler-case
 100         (%sys-read fd (inc-pointer buf start) (- end start))
 101       (ewouldblock () 0)
 102       (posix-error (err)
 103         (posix-file-error err *device* "reading data from"))
 104       (:no-error (nbytes)
 105         (if (zerop nbytes) :eof nbytes)))))
 106
 107 (defun %read-octets/timeout (fd vector start end timeout)
 108   (declare (type ub8-simple-vector vector)
 109            (special *device*))
 110   (with-pointer-to-vector-data (buf vector)
 111     (repeat-decreasing-timeout (remaining (clamp-timeout timeout) :rloop)
 112       (flet ((check-timeout ()
 113                (if (plusp remaining)
 114                    (poll-fd fd :input remaining)
 115                    (return-from :rloop 0))))
 116         (handler-case
 117             (%sys-read fd (inc-pointer buf start) (- end start))
 118           (ewouldblock () (check-timeout))
 119           (posix-error (err)
 120             (posix-file-error err *device* "reading data from"))
 121           (:no-error (nbytes)
 122             (return-from :rloop
 123               (if (zerop nbytes) :eof nbytes))))))))
 124 \f
 125
 126 ;;;-----------------------------------------------------------------------------
 127 ;;; File Descriptor writing
 128 ;;;-----------------------------------------------------------------------------
 129
 130 (defun %write-octets/non-blocking (fd vector start end)
 131   (declare (type ub8-simple-vector vector)
 132            (special *device*))
 133   (with-pointer-to-vector-data (buf vector)
 134     (handler-case
 135         (%sys-write fd (inc-pointer buf start) (- end start))
 136       (ewouldblock () 0)
 137       (epipe () :eof)
 138       (posix-error (err)
 139         (posix-file-error err *device* "writing data to"))
 140       (:no-error (nbytes)
 141         (if (zerop nbytes) :eof nbytes)))))
 142
 143 (defun %write-octets/timeout (fd vector start end timeout)
 144   (declare (type ub8-simple-vector vector)
 145            (special *device*))
 146   (with-pointer-to-vector-data (buf vector)
 147     (repeat-decreasing-timeout (remaining (clamp-timeout timeout) :rloop)
 148       (flet ((check-timeout ()
 149                (if (plusp remaining)
 150                    (poll-fd fd :output remaining)
 151                    (return-from :rloop 0))))
 152         (handler-case
 153             (%sys-write fd (inc-pointer buf start) (- end start))
 154           (ewouldblock () (check-timeout))
 155           (epipe () (return-from :rloop :eof))
 156           (posix-error (err)
 157             (posix-file-error err *device* "writing data to"))
 158           (:no-error (nbytes)
 159             (return-from :rloop
 160               (if (zerop nbytes) :eof nbytes))))))))