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   (:default-initargs :input-timeout nil
  16                      :output-timeout nil))
  17
  18 (defclass single-channel-device (device) ())
  19
  20 (defclass dual-channel-device (device) ())
  21
  22 (defclass direct-device (single-channel-device) ())
  23
  24 (defclass memory-buffer-device (direct-device) ())
  25
  26 (defclass socket-device (dual-channel-device)
  27   ((domain :initarg :domain)
  28    (type :initarg :type)
  29    (protocol :initarg :protocol)))
  30
  31 (deftype device-timeout ()
  32   `(or null non-negative-real))
  33
  34 (deftype stream-position () '(unsigned-byte 64))
  35 \f
  36
  37 ;;;-----------------------------------------------------------------------------
  38 ;;; Generic functions
  39 ;;;-----------------------------------------------------------------------------
  40
  41 (defgeneric device-open (device &rest initargs))
  42
  43 (defgeneric device-close (device))
  44
  45 (defgeneric device-read (device vector start end &optional timeout))
  46
  47 (defgeneric device-write (device vector start end &optional timeout))
  48
  49 (defgeneric device-position (device))
  50
  51 (defgeneric (setf device-position) (position device &rest args))
  52
  53 (defgeneric device-length (device))
  54 \f
  55
  56 ;;;-----------------------------------------------------------------------------
  57 ;;; Default no-op methods
  58 ;;;-----------------------------------------------------------------------------
  59
  60 (defmethod device-position ((device device))
  61   (values nil))
  62
  63 (defmethod (setf device-position) (position (device device) &rest args)
  64   (declare (ignore position args))
  65   (values nil))
  66
  67 (defmethod device-length ((device device))
  68   (values nil))
  69 \f
  70
  71 ;;;-----------------------------------------------------------------------------
  72 ;;; Get and Set O_NONBLOCK
  73 ;;;-----------------------------------------------------------------------------
  74
  75 (defun %get-fd-nonblock-mode (fd)
  76   (let ((current-flags (nix:fcntl fd nix:f-getfl)))
  77     (logtest nix:o-nonblock current-flags)))
  78
  79 (defun %set-fd-nonblock-mode (fd mode)
  80   (let* ((current-flags (nix:fcntl fd nix:f-getfl))
  81          (new-flags (if mode
  82                         (logior current-flags nix:o-nonblock)
  83                         (logandc2 current-flags nix:o-nonblock))))
  84     (when (/= new-flags current-flags)
  85       (nix:fcntl fd nix:f-setfl new-flags))
  86     (values mode)))
  87 \f
  88
  89 ;;;-----------------------------------------------------------------------------
  90 ;;; Default DEVICE-READ
  91 ;;;-----------------------------------------------------------------------------
  92
  93 (defmethod device-read ((device device) vector start end &optional timeout)
  94   (when (= start end) (return-from device-read 0))
  95   (if (and timeout (zerop timeout))
  96       (read-octets/non-blocking (input-handle-of device) vector start end)
  97       (read-octets/timeout (input-handle-of device) vector start end timeout)))
  98
  99 (defun read-octets/non-blocking (input-handle vector start end)
 100   (declare (type unsigned-byte input-handle)
 101            (type ub8-simple-vector vector)
 102            (type iobuf-index start end))
 103   (with-pointer-to-vector-data (buf vector)
 104     (handler-case
 105         (nix:repeat-upon-eintr
 106           (nix:read input-handle (inc-pointer buf start) (- end start)))
 107       (nix:ewouldblock () 0)
 108       (:no-error (nbytes)
 109         (if (zerop nbytes) :eof nbytes)))))
 110
 111 (defun read-octets/timeout (input-handle vector start end timeout)
 112   (declare (type unsigned-byte input-handle)
 113            (type ub8-simple-vector vector)
 114            (type iobuf-index start end)
 115            (type device-timeout timeout))
 116   (with-pointer-to-vector-data (buf vector)
 117     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 118       (flet ((check-timeout ()
 119                (if (plusp remaining)
 120                    (iomux:wait-until-fd-ready input-handle :input remaining)
 121                    (return-from :rloop 0))))
 122         (handler-case
 123             (nix:read input-handle (inc-pointer buf start) (- end start))
 124           (nix:eintr () (check-timeout))
 125           (nix:ewouldblock () (check-timeout))
 126           (:no-error (nbytes)
 127             (if (zerop nbytes) :eof nbytes)))))))
 128 \f
 129
 130 ;;;-----------------------------------------------------------------------------
 131 ;;; Default DEVICE-WRITE
 132 ;;;-----------------------------------------------------------------------------
 133
 134 (defmethod device-write ((device device) vector start end &optional timeout)
 135   (when (= start end) (return-from device-write 0))
 136   (if (and timeout (zerop timeout))
 137       (write-octets/non-blocking (output-handle-of device) vector start end)
 138       (write-octets/timeout (output-handle-of device) vector start end timeout)))
 139
 140 (defun write-octets/non-blocking (output-handle vector start end)
 141   (declare (type unsigned-byte output-handle)
 142            (type ub8-simple-vector vector)
 143            (type iobuf-index start end))
 144   (with-pointer-to-vector-data (buf vector)
 145     (handler-case
 146         (osicat-posix:repeat-upon-eintr
 147           (nix:write output-handle (inc-pointer buf start) (- end start)))
 148       (nix:ewouldblock () 0)
 149       (nix:epipe () :eof))))
 150
 151 (defun write-octets/timeout (output-handle vector start end timeout)
 152   (declare (type unsigned-byte output-handle)
 153            (type ub8-simple-vector vector)
 154            (type iobuf-index start end)
 155            (type device-timeout timeout))
 156   (with-pointer-to-vector-data (buf vector)
 157     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 158       (flet ((check-timeout ()
 159                (if (plusp remaining)
 160                    (iomux:wait-until-fd-ready output-handle :output remaining)
 161                    (return-from :rloop 0))))
 162         (handler-case
 163             (nix:write output-handle (inc-pointer buf start) (- end start))
 164           (nix:eintr () (check-timeout))
 165           (nix:ewouldblock () (check-timeout))
 166           (nix:epipe () :eof))))))