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