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 &optional abort))
  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   (if (and timeout (zerop timeout))
 131       (read-octets/non-blocking device vector start end)
 132       (read-octets/timeout device vector start end timeout)))
 133
 134 (defun read-octets/non-blocking (device vector start end)
 135   (declare (type device device)
 136            (type ub8-simple-vector vector)
 137            (type iobuf-index start end))
 138   (with-pointer-to-vector-data (buf vector)
 139     (handler-case
 140         (nix:repeat-upon-eintr
 141           (nix:read (input-handle-of device) (inc-pointer buf start) (- end start)))
 142       (nix:ewouldblock () 0)
 143       (nix:posix-error (err)
 144         (posix-file-error err device "reading data from"))
 145       (:no-error (nbytes)
 146         (if (zerop nbytes) :eof nbytes)))))
 147
 148 (defun read-octets/timeout (device vector start end timeout)
 149   (declare (type device device)
 150            (type ub8-simple-vector vector)
 151            (type iobuf-index start end)
 152            (type device-timeout timeout))
 153   (with-pointer-to-vector-data (buf vector)
 154     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 155       (flet ((check-timeout ()
 156                (if (plusp remaining)
 157                    (wait-for-input device remaining)
 158                    (return-from :rloop 0))))
 159         (handler-case
 160             (nix:read (input-handle-of device) (inc-pointer buf start) (- end start))
 161           (nix:eintr () (check-timeout))
 162           (nix:ewouldblock () (check-timeout))
 163           (nix:posix-error (err)
 164             (posix-file-error err device "reading data from"))
 165           (:no-error (nbytes)
 166             (return-from :rloop
 167               (if (zerop nbytes) :eof nbytes))))))))
 168 \f
 169
 170 ;;;-----------------------------------------------------------------------------
 171 ;;; Default DEVICE-WRITE
 172 ;;;-----------------------------------------------------------------------------
 173
 174 (defmethod device-write ((device device) vector start end &optional timeout)
 175   (when (= start end) (return-from device-write 0))
 176   (if (and timeout (zerop timeout))
 177       (write-octets/non-blocking device vector start end)
 178       (write-octets/timeout device vector start end timeout)))
 179
 180 (defun write-octets/non-blocking (device vector start end)
 181   (declare (type device device)
 182            (type ub8-simple-vector vector)
 183            (type iobuf-index start end))
 184   (with-pointer-to-vector-data (buf vector)
 185     (handler-case
 186         (osicat-posix:repeat-upon-eintr
 187           (nix:write (output-handle-of device) (inc-pointer buf start) (- end start)))
 188       (nix:ewouldblock () 0)
 189       (nix:epipe () :eof)
 190       (nix:posix-error (err)
 191         (posix-file-error err device "writing data to"))
 192       (:no-error (nbytes)
 193         (if (zerop nbytes) :eof nbytes)))))
 194
 195 (defun write-octets/timeout (device vector start end timeout)
 196   (declare (type device device)
 197            (type ub8-simple-vector vector)
 198            (type iobuf-index start end)
 199            (type device-timeout timeout))
 200   (with-pointer-to-vector-data (buf vector)
 201     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 202       (flet ((check-timeout ()
 203                (if (plusp remaining)
 204                    (wait-for-output device remaining)
 205                    (return-from :rloop 0))))
 206         (handler-case
 207             (nix:write (output-handle-of device) (inc-pointer buf start) (- end start))
 208           (nix:eintr () (check-timeout))
 209           (nix:ewouldblock () (check-timeout))
 210           (nix:epipe () (return-from :rloop :eof))
 211           (nix:posix-error (err)
 212             (posix-file-error err device "writing data to"))
 213           (:no-error (nbytes)
 214             (return-from :rloop
 215               (if (zerop nbytes) :eof nbytes))))))))