io.streams/zeta/device.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Device common functions.
   4 ;;;
   5
   6 (in-package :io.zeta-streams)
   7
   8 ;;;-----------------------------------------------------------------------------
   9 ;;; Device Classes and Types
  10 ;;;-----------------------------------------------------------------------------
  11
  12 (defclass device ()
  13   ((input-handle :initarg :input-handle :accessor input-handle-of)
  14    (output-handle :initarg :output-handle :accessor output-handle-of)))
  15
  16 (defclass single-channel-device (device) ())
  17
  18 (defclass dual-channel-device (device) ())
  19
  20 (defclass direct-device (single-channel-device) ())
  21
  22 (defclass memory-buffer-device (direct-device) ())
  23
  24 (defclass socket-device (dual-channel-device)
  25   ((domain :initarg :domain)
  26    (type :initarg :type)
  27    (protocol :initarg :protocol)))
  28
  29 (deftype device-timeout ()
  30   `(or null non-negative-real))
  31
  32 (deftype stream-position () '(unsigned-byte 64))
  33 \f
  34
  35 ;;;-----------------------------------------------------------------------------
  36 ;;; Generic functions
  37 ;;;-----------------------------------------------------------------------------
  38
  39 (defgeneric device-open (device &rest initargs))
  40
  41 (defgeneric device-close (device))
  42
  43 (defgeneric device-read (device vector start end &optional timeout))
  44
  45 (defgeneric device-write (device vector start end &optional timeout))
  46
  47 (defgeneric device-position (device))
  48
  49 (defgeneric (setf device-position) (position device &rest args))
  50
  51 (defgeneric device-length (device))
  52
  53 (defgeneric wait-for-input (device &optional timeout))
  54
  55 (defgeneric wait-for-output (device &optional timeout))
  56 \f
  57
  58 ;;;-----------------------------------------------------------------------------
  59 ;;; Helper macros
  60 ;;;-----------------------------------------------------------------------------
  61
  62 (defmacro with-device ((name) &body body)
  63   `(let ((*device* ,name))
  64      (declare (special *device*))
  65      ,@body))
  66 \f
  67
  68 ;;;-----------------------------------------------------------------------------
  69 ;;; Default no-op methods
  70 ;;;-----------------------------------------------------------------------------
  71
  72 (defmethod device-position ((device device))
  73   (values nil))
  74
  75 (defmethod (setf device-position) (position (device device) &rest args)
  76   (declare (ignore position args))
  77   (values nil))
  78
  79 (defmethod device-length ((device device))
  80   (values nil))
  81 \f
  82
  83 ;;;-----------------------------------------------------------------------------
  84 ;;; Get and Set O_NONBLOCK
  85 ;;;-----------------------------------------------------------------------------
  86
  87 (defun %get-fd-nonblock-mode (fd)
  88   (declare (special *device*))
  89   (handler-case
  90       (let ((current-flags (nix:fcntl fd nix:f-getfl)))
  91         (logtest nix:o-nonblock current-flags))
  92     (nix:posix-error (err)
  93       (posix-file-error err *device* "getting O_NONBLOCK from"))))
  94
  95 (defun %set-fd-nonblock-mode (fd mode)
  96   (declare (special *device*))
  97   (let* ((current-flags
  98           (handler-case
  99               (nix:fcntl fd nix:f-getfl)
 100             (nix:posix-error (err)
 101               (posix-file-error err *device* "getting O_NONBLOCK from"))))
 102          (new-flags (if mode
 103                         (logior current-flags nix:o-nonblock)
 104                         (logandc2 current-flags nix:o-nonblock))))
 105     (when (/= new-flags current-flags)
 106       (handler-case
 107           (nix:fcntl fd nix:f-setfl new-flags)
 108         (nix:posix-error (err)
 109           (posix-file-error err *device* "setting O_NONBLOCK on"))))
 110     (values mode)))
 111 \f
 112
 113 ;;;-----------------------------------------------------------------------------
 114 ;;; I/O WAIT
 115 ;;;-----------------------------------------------------------------------------
 116
 117 (defmethod wait-for-input ((device device) &optional timeout)
 118   (iomux:wait-until-fd-ready (input-handle-of device) :input timeout))
 119
 120 (defmethod wait-for-output ((device device) &optional timeout)
 121   (iomux:wait-until-fd-ready (output-handle-of device) :output timeout))
 122 \f
 123
 124 ;;;-----------------------------------------------------------------------------
 125 ;;; Default DEVICE-READ
 126 ;;;-----------------------------------------------------------------------------
 127
 128 (defmethod device-read ((device device) vector start end &optional timeout)
 129   (when (= start end) (return-from device-read 0))
 130   (with-device (device)
 131     (if (and timeout (zerop timeout))
 132         (read-octets/non-blocking device vector start end)
 133         (read-octets/timeout device vector start end timeout))))
 134
 135 (defun read-octets/non-blocking (device vector start end)
 136   (declare (type device device)
 137            (type ub8-simple-vector vector)
 138            (type iobuf-index start end))
 139   (with-pointer-to-vector-data (buf vector)
 140     (handler-case
 141         (nix:repeat-upon-eintr
 142           (nix:read (input-handle-of device) (inc-pointer buf start) (- end start)))
 143       (nix:ewouldblock () 0)
 144       (nix:posix-error (err)
 145         (posix-file-error err device "reading data from"))
 146       (:no-error (nbytes)
 147         (if (zerop nbytes) :eof nbytes)))))
 148
 149 (defun read-octets/timeout (device vector start end timeout)
 150   (declare (type device device)
 151            (type ub8-simple-vector vector)
 152            (type iobuf-index start end)
 153            (type device-timeout timeout))
 154   (with-pointer-to-vector-data (buf vector)
 155     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 156       (flet ((check-timeout ()
 157                (if (plusp remaining)
 158                    (wait-for-input device remaining)
 159                    (return-from :rloop 0))))
 160         (handler-case
 161             (nix:read (input-handle-of device) (inc-pointer buf start) (- end start))
 162           (nix:eintr () (check-timeout))
 163           (nix:ewouldblock () (check-timeout))
 164           (nix:posix-error (err)
 165             (posix-file-error err device "reading data from"))
 166           (:no-error (nbytes)
 167             (return-from :rloop
 168               (if (zerop nbytes) :eof nbytes))))))))
 169 \f
 170
 171 ;;;-----------------------------------------------------------------------------
 172 ;;; Default DEVICE-WRITE
 173 ;;;-----------------------------------------------------------------------------
 174
 175 (defmethod device-write ((device device) vector start end &optional timeout)
 176   (when (= start end) (return-from device-write 0))
 177   (with-device (device)
 178     (if (and timeout (zerop timeout))
 179         (write-octets/non-blocking device vector start end)
 180         (write-octets/timeout device vector start end timeout))))
 181
 182 (defun write-octets/non-blocking (device vector start end)
 183   (declare (type device device)
 184            (type ub8-simple-vector vector)
 185            (type iobuf-index start end))
 186   (with-pointer-to-vector-data (buf vector)
 187     (handler-case
 188         (osicat-posix:repeat-upon-eintr
 189           (nix:write (output-handle-of device) (inc-pointer buf start) (- end start)))
 190       (nix:ewouldblock () 0)
 191       (nix:epipe () :eof)
 192       (nix:posix-error (err)
 193         (posix-file-error err device "writing data to"))
 194       (:no-error (nbytes)
 195         (if (zerop nbytes) :eof nbytes)))))
 196
 197 (defun write-octets/timeout (device vector start end timeout)
 198   (declare (type device device)
 199            (type ub8-simple-vector vector)
 200            (type iobuf-index start end)
 201            (type device-timeout timeout))
 202   (with-pointer-to-vector-data (buf vector)
 203     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 204       (flet ((check-timeout ()
 205                (if (plusp remaining)
 206                    (wait-for-output device remaining)
 207                    (return-from :rloop 0))))
 208         (handler-case
 209             (nix:write (output-handle-of device) (inc-pointer buf start) (- end start))
 210           (nix:eintr () (check-timeout))
 211           (nix:ewouldblock () (check-timeout))
 212           (nix:epipe () (return-from :rloop :eof))
 213           (nix:posix-error (err)
 214             (posix-file-error err device "writing data to"))
 215           (:no-error (nbytes)
 216             (return-from :rloop
 217               (if (zerop nbytes) :eof nbytes))))))))