src/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 :iolib.zstreams)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; FD polling
  10 ;;;-------------------------------------------------------------------------
  11
  12 (defun compute-poll-flags (type)
  13   (ecase type
  14     (:input  (logior isys:pollin isys:pollrdhup isys:pollpri))
  15     (:output (logior isys:pollout))
  16     (:io     (logior isys:pollin isys:pollrdhup isys:pollpri isys:pollout))))
  17
  18 (defun process-poll-revents (fd event-type revents)
  19   (flet ((poll-error ()
  20            (error 'isys:poll-error :code isys:ebadf :identifier :ebadf
  21                   :os-handle fd :event-type event-type
  22                   :message "invalid OS handle")))
  23     (let ((readp  nil) (rhupp nil)
  24           (writep nil) (whupp nil))
  25       (flags-case revents
  26         ((isys:pollin isys:pollpri)   (setf readp t))
  27         ((isys:pollrdhup)             (setf rhupp t))
  28         ((isys:pollout)               (setf writep t))
  29         ((isys:pollhup)               (setf whupp t))
  30         ((isys:pollerr isys: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   (isys:repeat-upon-condition-decreasing-timeout
  40       ((isys:eintr) remaining-time timeout)
  41     (isys: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 'isys:pollfd)
  57       (isys:bzero pollfd isys:size-of-pollfd)
  58       (with-foreign-slots ((isys:fd isys:events isys:revents)
  59                            pollfd isys:pollfd)
  60         (setf isys:fd file-descriptor
  61               isys:events (compute-poll-flags event-type))
  62         (handler-case
  63             (cond
  64               ((plusp (%poll pollfd timeout))
  65                (process-poll-revents isys:fd event-type isys:revents))
  66               (t
  67                (error 'isys:poll-timeout
  68                       :os-handle file-descriptor
  69                       :event-type event-type)))
  70           (isys:syscall-error (err) (poll-error err)))))))
  71 \f
  72
  73 ;;;-------------------------------------------------------------------------
  74 ;;; Set FD nonblocking
  75 ;;;-------------------------------------------------------------------------
  76
  77 (defun %set-fd-nonblock (fd)
  78   (declare (special *device*))
  79   (handler-case
  80       (with-foreign-object (arg :int)
  81         (setf (mem-aref arg :int) 1)
  82         (isys:ioctl fd isys:fionbio arg))
  83     (isys:syscall-error (err)
  84       (posix-file-error err *device* "issuing FIONBIO IOCTL on")))
  85   (values))
  86 \f
  87
  88 ;;;-------------------------------------------------------------------------
  89 ;;; Get number of bytes availabe on FD
  90 ;;;-------------------------------------------------------------------------
  91
  92 (defun %get-fd-nbytes (fd)
  93   (declare (special *device*))
  94   (handler-case
  95       (with-foreign-object (arg :int)
  96         (isys:ioctl fd isys:fionread arg)
  97         (mem-aref arg :int))
  98     (isys:syscall-error (err)
  99       (posix-file-error err *device* "issuing FIONREAD IOCTL on"))))
 100 \f
 101
 102 ;;;-------------------------------------------------------------------------
 103 ;;; File Descriptor reading
 104 ;;;-------------------------------------------------------------------------
 105
 106 (defun %read-octets/non-blocking (fd vector start end)
 107   (declare (type ub8-simple-vector vector)
 108            (special *device*))
 109   (with-pointer-to-vector-data (buf vector)
 110     (handler-case
 111         (isys:read fd (inc-pointer buf start) (- end start))
 112       (isys:ewouldblock () 0)
 113       (isys:syscall-error (err)
 114         (posix-file-error err *device* "reading data from"))
 115       (:no-error (nbytes)
 116         (if (zerop nbytes) :eof nbytes)))))
 117
 118 (defun %read-octets/timeout (fd vector start end timeout)
 119   (declare (type ub8-simple-vector vector)
 120            (special *device*))
 121   (with-pointer-to-vector-data (buf vector)
 122     (isys:repeat-decreasing-timeout
 123         (remaining (clamp-timeout timeout) :rloop)
 124       (flet ((check-timeout ()
 125                (if (plusp remaining)
 126                    (poll-fd fd :input remaining)
 127                    (return-from :rloop 0))))
 128         (handler-case
 129             (isys:read fd (inc-pointer buf start) (- end start))
 130           (isys:ewouldblock () (check-timeout))
 131           (isys:syscall-error (err)
 132             (posix-file-error err *device* "reading data from"))
 133           (:no-error (nbytes)
 134             (return-from :rloop
 135               (if (zerop nbytes) :eof nbytes))))))))
 136 \f
 137
 138 ;;;-------------------------------------------------------------------------
 139 ;;; File Descriptor writing
 140 ;;;-------------------------------------------------------------------------
 141
 142 (defun %write-octets/non-blocking (fd vector start end)
 143   (declare (type ub8-simple-vector vector)
 144            (special *device*))
 145   (with-pointer-to-vector-data (buf vector)
 146     (handler-case
 147         (isys:write fd (inc-pointer buf start) (- end start))
 148       (isys:ewouldblock () 0)
 149       (isys:epipe () :hangup)
 150       (isys:syscall-error (err)
 151         (posix-file-error err *device* "writing data to"))
 152       (:no-error (nbytes)
 153         (if (zerop nbytes) :hangup nbytes)))))
 154
 155 (defun %write-octets/timeout (fd vector start end timeout)
 156   (declare (type ub8-simple-vector vector)
 157            (special *device*))
 158   (with-pointer-to-vector-data (buf vector)
 159     (isys:repeat-decreasing-timeout
 160         (remaining (clamp-timeout timeout) :rloop)
 161       (flet ((check-timeout ()
 162                (if (plusp remaining)
 163                    (poll-fd fd :output remaining)
 164                    (return-from :rloop 0))))
 165         (handler-case
 166             (isys:write fd (inc-pointer buf start) (- end start))
 167           (isys:ewouldblock () (check-timeout))
 168           (isys:epipe () (return-from :rloop :hangup))
 169           (isys:syscall-error (err)
 170             (posix-file-error err *device* "writing data to"))
 171           (:no-error (nbytes)
 172             (return-from :rloop
 173               (if (zerop nbytes) :hangup nbytes))))))))