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 ;;; Get and Set O_NONBLOCK
  10 ;;;-----------------------------------------------------------------------------
  11
  12 (defun %get-fd-nonblock-mode (fd)
  13   (let ((current-flags (nix:fcntl fd nix:f-getfl)))
  14     (logtest nix:o-nonblock current-flags)))
  15
  16 (defun %set-fd-nonblock-mode (fd mode)
  17   (let* ((current-flags (nix:fcntl fd nix:f-getfl))
  18          (new-flags (if mode
  19                         (logior current-flags nix:o-nonblock)
  20                         (logandc2 current-flags nix:o-nonblock))))
  21     (when (/= new-flags current-flags)
  22       (nix:fcntl fd nix:f-setfl new-flags))
  23     (values mode)))
  24 \f
  25
  26 ;;;-----------------------------------------------------------------------------
  27 ;;; Default DEVICE-READ
  28 ;;;-----------------------------------------------------------------------------
  29
  30 (defmethod device-read ((device device) buffer start end &optional (timeout nil timeoutp))
  31   (let ((timeout (if timeoutp timeout (input-timeout-of device)))
  32         (nbytes (if (and timeout (zerop timeout))
  33                     (read-octets-non-blocking (input-handle-of device) buffer start end)
  34                     (read-octets-with-timeout (input-handle-of device) buffer start end timeout))))
  35     (when (plusp nbytes) (incf (device-position device) nbytes))
  36     (values nbytes)))
  37
  38 (defun read-octets-non-blocking (fd buffer start end)
  39   (declare (type unsigned-byte fd)
  40            (type ub8-sarray buffer)
  41            (type unsigned-byte start end))
  42   (with-pointer-to-vector-data (buf buffer)
  43     (handler-case
  44         (nix:repeat-upon-eintr
  45           (nix:read fd (inc-pointer buf start) (- end start)))
  46       (nix:ewouldblock () 0)
  47       (:no-error (nbytes)
  48         (if (zerop nbytes) :eof nbytes)))))
  49
  50 (defun read-octets-with-timeout (fd buffer start end timeout)
  51   (declare (type unsigned-byte fd)
  52            (type ub8-sarray buffer)
  53            (type unsigned-byte start end))
  54   (with-pointer-to-vector-data (buf buffer)
  55     (nix:repeat-decreasing-timeout (remaining timeout nil)
  56       (flet ((check-timeout ()
  57                (if (plusp remaining)
  58                    (iomux:wait-until-fd-ready fd :input remaining)
  59                    (return 0))))
  60         (handler-case
  61             (nix:read fd (inc-pointer buf start) (- end start))
  62           (nix:eintr () (check-timeout))
  63           (nix:ewouldblock () (check-timeout))
  64           (:no-error (nbytes)
  65             (if (zerop nbytes) :eof nbytes)))))))
  66 \f
  67
  68 ;;;-----------------------------------------------------------------------------
  69 ;;; Default DEVICE-WRITE
  70 ;;;-----------------------------------------------------------------------------
  71
  72 (defmethod device-write ((device device) buffer start end &optional (timeout nil timeoutp))
  73   (let* ((timeout (if timeoutp timeout (output-timeout-of device)))
  74          (nbytes (if (and timeout (zerop timeout))
  75                      (write-octets-non-blocking (output-handle-of device) buffer start end)
  76                      (write-octets-with-timeout (output-handle-of device) buffer start end timeout))))
  77     (when (plusp nbytes) (incf (device-position device) nbytes))
  78     (values nbytes)))
  79
  80 (defun write-octets-non-blocking (fd buffer start end)
  81   (declare (type unsigned-byte fd)
  82            (type ub8-sarray buffer)
  83            (type unsigned-byte start end))
  84   (with-pointer-to-vector-data (buf buffer)
  85     (handler-case
  86         (osicat-posix:repeat-upon-eintr
  87           (nix:write fd (inc-pointer buf start) (- end start)))
  88       (nix:ewouldblock () 0)
  89       (:no-error (nbytes)
  90         (if (zerop nbytes) :eof nbytes)))))
  91
  92 (defun write-octets-with-timeout (fd buffer start end timeout)
  93   (declare (type unsigned-byte fd)
  94            (type ub8-sarray buffer)
  95            (type unsigned-byte start end))
  96   (with-pointer-to-vector-data (buf buffer)
  97     (nix:repeat-decreasing-timeout (remaining timeout nil)
  98       (flet ((check-timeout ()
  99                (if (plusp remaining)
 100                    (iomux:wait-until-fd-ready fd :output remaining)
 101                    (return 0))))
 102         (handler-case
 103             (nix:write fd (inc-pointer buf start) (- end start))
 104           (nix:eintr () (check-timeout))
 105           (nix:ewouldblock () (check-timeout))
 106           (:no-error (nbytes)
 107             (return (if (zerop nbytes) :eof nbytes))))))))