io.streams/zeta/buffer.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Device buffers.
   4 ;;;
   5
   6 (in-package :io.zeta-streams)
   7
   8 ;;;-----------------------------------------------------------------------------
   9 ;;; Buffer Classes and Types
  10 ;;;-----------------------------------------------------------------------------
  11
  12 (defclass buffer (device)
  13   ((single-channel-p :initarg :single-channel :accessor single-channel-buffer-p)
  14    (last-io-op :initform nil :accessor last-io-op-of)
  15    (input-buffer :initarg :input-buffer :accessor input-buffer-of)
  16    (output-buffer :initarg :output-buffer :accessor output-buffer-of))
  17   (:default-initargs :input-buffer nil
  18                      :output-buffer nil))
  19 \f
  20
  21 ;;;-----------------------------------------------------------------------------
  22 ;;; Buffer Constructors
  23 ;;;-----------------------------------------------------------------------------
  24
  25 (defmethod initialize-instance :after ((buffer buffer) &key
  26                                        (single-channel nil single-channel-provided)
  27                                        input-buffer-size output-buffer-size)
  28   (with-accessors ((single-channel-p single-channel-buffer-p)
  29                    (input-handle input-handle-of)
  30                    (input-buffer input-buffer-of)
  31                    (output-buffer output-buffer-of))
  32       buffer
  33     (unless single-channel-provided
  34       (setf single-channel-p (typep input-handle 'single-channel-device)))
  35     (if input-buffer
  36         (check-type input-buffer iobuf)
  37         (setf input-buffer (make-iobuf input-buffer-size)))
  38     (if single-channel
  39         (setf output-buffer input-buffer)
  40         (cond
  41           (output-buffer
  42            (check-type output-buffer iobuf)
  43            (assert (not (eq input-buffer output-buffer))))
  44           (t (setf output-buffer (make-iobuf output-buffer-size)))))))
  45 \f
  46
  47 ;;;-----------------------------------------------------------------------------
  48 ;;; Buffer Generic Functions
  49 ;;;-----------------------------------------------------------------------------
  50
  51 (defgeneric buffer-clear-input (buffer))
  52
  53 (defgeneric buffer-clear-output (buffer))
  54
  55 (defgeneric buffer-flush-output (buffer &optional timeout))
  56 \f
  57
  58 ;;;-----------------------------------------------------------------------------
  59 ;;; Buffer DEVICE-READ
  60 ;;;-----------------------------------------------------------------------------
  61
  62 (defmethod device-read ((device buffer) buffer start end &optional timeout)
  63   (when (= start end) (return-from device-read 0))
  64   (read-octets/buffered device buffer start end timeout))
  65
  66 (defun read-octets/buffered (device vector start end timeout)
  67   (declare (type buffer device)
  68            (type ub8-simple-vector vector)
  69            (type iobuf-index start end)
  70            (type device-timeout timeout))
  71   (with-accessors ((input-handle input-handle-of)
  72                    (input-buffer input-buffer-of)
  73                    (output-handle output-handle-of)
  74                    (output-buffer output-buffer-of))
  75       device
  76     ;; If the previous operation was a write, try to flush the output buffer.
  77     ;; If the buffer couldn't be flushed at once, signal an error
  78     (synchronize-input device output-handle output-buffer)
  79     (cond
  80       ((iobuf-empty-p input-buffer)
  81        (let ((nbytes
  82               (fill-input-buffer device input-handle input-buffer timeout)))
  83          (if (iobuf-empty-p input-buffer)
  84              (if (eql :eof nbytes) :eof 0)
  85              (iobuf->vector input-buffer vector start end))))
  86       (t
  87        (iobuf->vector input-buffer vector start end)))))
  88
  89 (defun synchronize-input (device output-handle output-buffer)
  90   (when (and (single-channel-buffer-p device)
  91              (eql :write (last-io-op-of device)))
  92     (if (plusp (flush-output-buffer output-handle output-buffer 0))
  93         (error "Could not flush the entire write buffer !")
  94         (iobuf-reset output-buffer))))
  95
  96 (defun fill-input-buffer (device input-handle input-buffer timeout)
  97   (multiple-value-bind (data start end)
  98       (iobuf-next-empty-zone input-buffer)
  99     (let ((nbytes
 100            (device-read input-handle data start end timeout)))
 101       (setf (iobuf-end input-buffer) (+ start nbytes))
 102       (setf (last-io-op-of device) :read)
 103       (values nbytes))))
 104
 105 (defun flush-input-buffer (input-buffer)
 106   (prog1
 107       (iobuf-available-octets input-buffer)
 108     (iobuf-reset input-buffer)))
 109 \f
 110
 111 ;;;-----------------------------------------------------------------------------
 112 ;;; Buffer DEVICE-WRITE
 113 ;;;-----------------------------------------------------------------------------
 114
 115 (defmethod device-write ((device buffer) buffer start end &optional timeout)
 116   (when (= start end) (return-from device-write 0))
 117   (write-octets/buffered device buffer start end timeout))
 118
 119 (defun write-octets/buffered (device vector start end timeout)
 120   (declare (type buffer device)
 121            (type ub8-simple-vector vector)
 122            (type iobuf-index start end)
 123            (type device-timeout timeout))
 124   (with-accessors ((output-handle output-handle-of)
 125                    (output-buffer output-buffer-of))
 126       device
 127     ;; If the previous operation was a read, flush the read buffer
 128     ;; and reposition the file offset accordingly
 129     (synchronize-output device)
 130     (prog1
 131         (vector->iobuf output-buffer vector start end)
 132       (setf (last-io-op-of device) :write)
 133       (when (iobuf-full-p output-buffer)
 134         (flush-output-buffer output-handle output-buffer timeout)))))
 135
 136 (defun synchronize-output (device)
 137   (when (and (single-channel-buffer-p device)
 138              (eql :read (last-io-op-of device)))
 139     (let ((nbytes (flush-input-buffer (input-buffer-of device))))
 140       (setf (device-position device :from :current) (- nbytes)))))
 141
 142 (defun flush-output-buffer (output-handle output-buffer timeout)
 143   (multiple-value-bind (data start end)
 144       (iobuf-next-data-zone output-buffer)
 145     (let ((nbytes
 146            (device-write output-handle data start end timeout)))
 147       (setf (iobuf-start output-buffer) (+ start nbytes))))
 148   (iobuf-available-octets output-buffer))
 149 \f
 150
 151 ;;;-----------------------------------------------------------------------------
 152 ;;; Buffer DEVICE-POSITION
 153 ;;;-----------------------------------------------------------------------------
 154
 155 (defmethod device-position ((device buffer))
 156   (when-let ((handle-position
 157               (device-position (input-handle-of device))))
 158     (+ handle-position (iobuf-available-octets (input-buffer-of device)))))
 159
 160 (defmethod (setf device-position) (position (device buffer) &key (from :start))
 161   (setf (device-position device :from from) position))
 162 \f
 163
 164 ;;;-----------------------------------------------------------------------------
 165 ;;; Buffer cleaning
 166 ;;;-----------------------------------------------------------------------------
 167
 168 (defmethod buffer-clear-input ((buffer buffer))
 169   (iobuf-reset (input-buffer-of buffer)))
 170
 171 (defmethod buffer-clear-output ((buffer buffer))
 172   (iobuf-reset (output-buffer-of buffer)))
 173
 174 (defmethod buffer-flush-output ((buffer buffer) &optional timeout)
 175   (with-accessors ((output-handle output-handle-of)
 176                    (output-buffer output-buffer-of))
 177       buffer
 178     (flush-output-buffer output-handle output-buffer timeout)))