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   (let ((nbytes (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     (cond
  99       ((eql :eof nbytes) (return-from device-read :eof))
 100       ((and (plusp nbytes) (typep device 'single-channel-device))
 101        (incf (device-position device) nbytes)))
 102     (values nbytes)))
 103
 104 (defun read-octets/non-blocking (input-handle vector start end)
 105   (declare (type unsigned-byte input-handle)
 106            (type ub8-simple-vector vector)
 107            (type iobuf-index start end))
 108   (with-pointer-to-vector-data (buf vector)
 109     (handler-case
 110         (nix:repeat-upon-eintr
 111           (nix:read input-handle (inc-pointer buf start) (- end start)))
 112       (nix:ewouldblock () 0)
 113       (:no-error (nbytes)
 114         (if (zerop nbytes) :eof nbytes)))))
 115
 116 (defun read-octets/timeout (input-handle vector start end timeout)
 117   (declare (type unsigned-byte input-handle)
 118            (type ub8-simple-vector vector)
 119            (type iobuf-index start end)
 120            (type device-timeout timeout))
 121   (with-pointer-to-vector-data (buf vector)
 122     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 123       (flet ((check-timeout ()
 124                (if (plusp remaining)
 125                    (iomux:wait-until-fd-ready input-handle :input remaining)
 126                    (return-from :rloop 0))))
 127         (handler-case
 128             (nix:read input-handle (inc-pointer buf start) (- end start))
 129           (nix:eintr () (check-timeout))
 130           (nix:ewouldblock () (check-timeout))
 131           (:no-error (nbytes)
 132             (if (zerop nbytes) :eof nbytes)))))))
 133 \f
 134
 135 ;;;-----------------------------------------------------------------------------
 136 ;;; Default DEVICE-WRITE
 137 ;;;-----------------------------------------------------------------------------
 138
 139 (defmethod device-write ((device device) vector start end &optional timeout)
 140   (when (= start end) (return-from device-write 0))
 141   (let ((nbytes (if (and timeout (zerop timeout))
 142                     (write-octets/non-blocking (output-handle-of device) vector start end)
 143                     (write-octets/timeout (output-handle-of device) vector start end timeout))))
 144     (cond
 145       ((eql :eof nbytes) (return-from device-write :eof))
 146       ((and (plusp nbytes) (typep device 'single-channel-device))
 147        (incf (device-position device) nbytes)))
 148     (values nbytes)))
 149
 150 (defun write-octets/non-blocking (output-handle vector start end)
 151   (declare (type unsigned-byte output-handle)
 152            (type ub8-simple-vector vector)
 153            (type iobuf-index start end))
 154   (with-pointer-to-vector-data (buf vector)
 155     (handler-case
 156         (osicat-posix:repeat-upon-eintr
 157           (nix:write output-handle (inc-pointer buf start) (- end start)))
 158       (nix:ewouldblock () 0)
 159       (nix:epipe () :eof))))
 160
 161 (defun write-octets/timeout (output-handle vector start end timeout)
 162   (declare (type unsigned-byte output-handle)
 163            (type ub8-simple-vector vector)
 164            (type iobuf-index start end)
 165            (type device-timeout timeout))
 166   (with-pointer-to-vector-data (buf vector)
 167     (nix:repeat-decreasing-timeout (remaining timeout :rloop)
 168       (flet ((check-timeout ()
 169                (if (plusp remaining)
 170                    (iomux:wait-until-fd-ready output-handle :output remaining)
 171                    (return-from :rloop 0))))
 172         (handler-case
 173             (nix:write output-handle (inc-pointer buf start) (- end start))
 174           (nix:eintr () (check-timeout))
 175           (nix:ewouldblock () (check-timeout))
 176           (nix:epipe () :eof))))))