io.streams/zeta/common.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Common functions.
   4 ;;;
   5
   6 (in-package :io.zeta-streams)
   7
   8 ;;;-----------------------------------------------------------------------------
   9 ;;; Default no-op methods
  10 ;;;-----------------------------------------------------------------------------
  11
  12 (defmethod device-clear-input ((device device))
  13   (values device))
  14
  15 (defmethod device-clear-output ((device device))
  16   (values device))
  17
  18 (defmethod device-flush-output ((device device) &optional timeout)
  19   (declare (ignore timeout))
  20   (values device))
  21
  22 (defmethod device-position ((device device))
  23   (values nil))
  24
  25 (defmethod (setf device-position) (position (device device) &rest args)
  26   (declare (ignore position args))
  27   (values nil))
  28
  29 (defmethod device-length ((device device))
  30   (values nil))
  31 \f
  32
  33 ;;;-----------------------------------------------------------------------------
  34 ;;; Get and Set O_NONBLOCK
  35 ;;;-----------------------------------------------------------------------------
  36
  37 (defun %get-fd-nonblock-mode (fd)
  38   (let ((current-flags (nix:fcntl fd nix:f-getfl)))
  39     (logtest nix:o-nonblock current-flags)))
  40
  41 (defun %set-fd-nonblock-mode (fd mode)
  42   (let* ((current-flags (nix:fcntl fd nix:f-getfl))
  43          (new-flags (if mode
  44                         (logior current-flags nix:o-nonblock)
  45                         (logandc2 current-flags nix:o-nonblock))))
  46     (when (/= new-flags current-flags)
  47       (nix:fcntl fd nix:f-setfl new-flags))
  48     (values mode)))
  49 \f
  50
  51 ;;;-----------------------------------------------------------------------------
  52 ;;; Default DEVICE-READ
  53 ;;;-----------------------------------------------------------------------------
  54
  55 (defmethod device-read ((device device) buffer start end &optional (timeout nil timeoutp))
  56   (when (= start end) (return-from device-read 0))
  57   (let* ((timeout (if timeoutp timeout (input-timeout-of device)))
  58          (nbytes (if (and timeout (zerop timeout))
  59                      (read-octets-non-blocking (input-handle-of device) buffer start end)
  60                      (read-octets-with-timeout (input-handle-of device) buffer start end timeout))))
  61     (when (plusp nbytes) (incf (device-position device) nbytes))
  62     (values nbytes)))
  63
  64 (defun read-octets-non-blocking (fd buffer start end)
  65   (declare (type unsigned-byte fd)
  66            (type ub8-sarray buffer)
  67            (type unsigned-byte start end))
  68   (with-pointer-to-vector-data (buf buffer)
  69     (handler-case
  70         (nix:repeat-upon-eintr
  71           (nix:read fd (inc-pointer buf start) (- end start)))
  72       (nix:ewouldblock () 0)
  73       (:no-error (nbytes)
  74         (if (zerop nbytes) :eof nbytes)))))
  75
  76 (defun read-octets-with-timeout (fd buffer start end timeout)
  77   (declare (type unsigned-byte fd)
  78            (type ub8-sarray buffer)
  79            (type unsigned-byte start end))
  80   (with-pointer-to-vector-data (buf buffer)
  81     (nix:repeat-decreasing-timeout (remaining timeout nil)
  82       (flet ((check-timeout ()
  83                (if (plusp remaining)
  84                    (iomux:wait-until-fd-ready fd :input remaining)
  85                    (return 0))))
  86         (handler-case
  87             (nix:read fd (inc-pointer buf start) (- end start))
  88           (nix:eintr () (check-timeout))
  89           (nix:ewouldblock () (check-timeout))
  90           (:no-error (nbytes)
  91             (if (zerop nbytes) :eof nbytes)))))))
  92 \f
  93
  94 ;;;-----------------------------------------------------------------------------
  95 ;;; Default DEVICE-WRITE
  96 ;;;-----------------------------------------------------------------------------
  97
  98 (defmethod device-write ((device device) buffer start end &optional (timeout nil timeoutp))
  99   (when (= start end) (return-from device-write 0))
 100   (let* ((timeout (if timeoutp timeout (output-timeout-of device)))
 101          (nbytes (if (and timeout (zerop timeout))
 102                      (write-octets-non-blocking (output-handle-of device) buffer start end)
 103                      (write-octets-with-timeout (output-handle-of device) buffer start end timeout))))
 104     (when (plusp nbytes) (incf (device-position device) nbytes))
 105     (values nbytes)))
 106
 107 (defun write-octets-non-blocking (fd buffer start end)
 108   (declare (type unsigned-byte fd)
 109            (type ub8-sarray buffer)
 110            (type unsigned-byte start end))
 111   (with-pointer-to-vector-data (buf buffer)
 112     (handler-case
 113         (osicat-posix:repeat-upon-eintr
 114           (nix:write fd (inc-pointer buf start) (- end start)))
 115       (nix:ewouldblock () 0)
 116       (:no-error (nbytes)
 117         (if (zerop nbytes) :eof nbytes)))))
 118
 119 (defun write-octets-with-timeout (fd buffer start end timeout)
 120   (declare (type unsigned-byte fd)
 121            (type ub8-sarray buffer)
 122            (type unsigned-byte start end))
 123   (with-pointer-to-vector-data (buf buffer)
 124     (nix:repeat-decreasing-timeout (remaining timeout nil)
 125       (flet ((check-timeout ()
 126                (if (plusp remaining)
 127                    (iomux:wait-until-fd-ready fd :output remaining)
 128                    (return 0))))
 129         (handler-case
 130             (nix:write fd (inc-pointer buf start) (- end start))
 131           (nix:eintr () (check-timeout))
 132           (nix:ewouldblock () (check-timeout))
 133           (:no-error (nbytes)
 134             (return (if (zerop nbytes) :eof nbytes))))))))