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 \f
  53
  54 ;;;-----------------------------------------------------------------------------
  55 ;;; Helper macros
  56 ;;;-----------------------------------------------------------------------------
  57
  58 (defmacro with-device ((name) &body body)
  59   `(let ((*device* ,name))
  60      (declare (special *device*))
  61      ,@body))
  62 \f
  63
  64 ;;;-----------------------------------------------------------------------------
  65 ;;; Default no-op methods
  66 ;;;-----------------------------------------------------------------------------
  67
  68 (defmethod device-position ((device device))
  69   (values nil))
  70
  71 (defmethod (setf device-position) (position (device device) &rest args)
  72   (declare (ignore position args))
  73   (values nil))
  74
  75 (defmethod device-length ((device device))
  76   (values nil))
  77 \f
  78
  79 ;;;-----------------------------------------------------------------------------
  80 ;;; Get and Set O_NONBLOCK
  81 ;;;-----------------------------------------------------------------------------
  82
  83 (defun %get-fd-nonblock-mode (fd)
  84   (declare (special *device*))
  85   (handler-case
  86       (let ((current-flags (nix:fcntl fd nix:f-getfl)))
  87         (logtest nix:o-nonblock current-flags))
  88     (nix:posix-error (err)
  89       (posix-file-error err *device* "getting O_NONBLOCK from"))))
  90
  91 (defun %set-fd-nonblock-mode (fd mode)
  92   (declare (special *device*))
  93   (let* ((current-flags
  94           (handler-case
  95               (nix:fcntl fd nix:f-getfl)
  96             (nix:posix-error (err)
  97               (posix-file-error err *device* "getting O_NONBLOCK from"))))
  98          (new-flags (if mode
  99                         (logior current-flags nix:o-nonblock)
 100                         (logandc2 current-flags nix:o-nonblock))))
 101     (when (/= new-flags current-flags)
 102       (handler-case
 103           (nix:fcntl fd nix:f-setfl new-flags)
 104         (nix:posix-error (err)
 105           (posix-file-error err *device* "setting O_NONBLOCK on"))))
 106     (values mode)))
 107 \f
 108
 109 ;;;-----------------------------------------------------------------------------
 110 ;;; Default DEVICE-READ
 111 ;;;-----------------------------------------------------------------------------
 112
 113 (defmethod device-read ((device device) vector start end &optional timeout)
 114   (when (= start end) (return-from device-read 0))
 115   (with-device (device)
 116     (if (and timeout (zerop timeout))
 117         (read-octets/non-blocking (input-handle-of device) vector start end)
 118         (read-octets/timeout (input-handle-of device) vector start end timeout))))
 119
 120 (defun read-octets/non-blocking (input-handle vector start end)
 121   (declare (type unsigned-byte input-handle)
 122            (type ub8-simple-vector vector)
 123            (type iobuf-index start end)
 124            (special *device*))
 125   (with-pointer-to-vector-data (buf vector)
 126     (handler-case
 127         (nix:repeat-upon-eintr
 128           (nix:read input-handle (inc-pointer buf start) (- end start)))
 129       (nix:ewouldblock () 0)
 130       (nix:posix-error (err)
 131         (posix-file-error err *device* "reading data from"))
 132       (:no-error (nbytes)
 133         (if (zerop nbytes) :eof nbytes)))))
 134
 135 (defun read-octets/timeout (input-handle vector start end timeout)
 136   (declare (type unsigned-byte input-handle)
 137            (type ub8-simple-vector vector)
 138            (type iobuf-index start end)
 139            (type device-timeout timeout)
 140            (special *device*))
 141   (with-pointer-to-vector-data (buf vector)
 142     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 143       (flet ((check-timeout ()
 144                (if (plusp remaining)
 145                    (iomux:wait-until-fd-ready input-handle :input remaining)
 146                    (return-from :rloop 0))))
 147         (handler-case
 148             (nix:read input-handle (inc-pointer buf start) (- end start))
 149           (nix:eintr () (check-timeout))
 150           (nix:ewouldblock () (check-timeout))
 151           (nix:posix-error (err)
 152             (posix-file-error err *device* "reading data from"))
 153           (:no-error (nbytes)
 154             (return-from :rloop
 155               (if (zerop nbytes) :eof nbytes))))))))
 156 \f
 157
 158 ;;;-----------------------------------------------------------------------------
 159 ;;; Default DEVICE-WRITE
 160 ;;;-----------------------------------------------------------------------------
 161
 162 (defmethod device-write ((device device) vector start end &optional timeout)
 163   (when (= start end) (return-from device-write 0))
 164   (with-device (device)
 165     (if (and timeout (zerop timeout))
 166         (write-octets/non-blocking (output-handle-of device) vector start end)
 167         (write-octets/timeout (output-handle-of device) vector start end timeout))))
 168
 169 (defun write-octets/non-blocking (output-handle vector start end)
 170   (declare (type unsigned-byte output-handle)
 171            (type ub8-simple-vector vector)
 172            (type iobuf-index start end)
 173            (special *device*))
 174   (with-pointer-to-vector-data (buf vector)
 175     (handler-case
 176         (osicat-posix:repeat-upon-eintr
 177           (nix:write output-handle (inc-pointer buf start) (- end start)))
 178       (nix:ewouldblock () 0)
 179       (nix:epipe () :eof)
 180       (nix:posix-error (err)
 181         (posix-file-error err *device* "writing data to"))
 182       (:no-error (nbytes)
 183         (if (zerop nbytes) :eof nbytes)))))
 184
 185 (defun write-octets/timeout (output-handle vector start end timeout)
 186   (declare (type unsigned-byte output-handle)
 187            (type ub8-simple-vector vector)
 188            (type iobuf-index start end)
 189            (type device-timeout timeout)
 190            (special *device*))
 191   (with-pointer-to-vector-data (buf vector)
 192     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 193       (flet ((check-timeout ()
 194                (if (plusp remaining)
 195                    (iomux:wait-until-fd-ready output-handle :output remaining)
 196                    (return-from :rloop 0))))
 197         (handler-case
 198             (nix:write output-handle (inc-pointer buf start) (- end start))
 199           (nix:eintr () (check-timeout))
 200           (nix:ewouldblock () (check-timeout))
 201           (nix:epipe () (return-from :rloop :eof))
 202           (nix:posix-error (err)
 203             (posix-file-error err *device* "writing data to"))
 204           (:no-error (nbytes)
 205             (return-from :rloop
 206               (if (zerop nbytes) :eof nbytes))))))))