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    (input-buffer :initarg :input-buffer :accessor input-buffer-of)
  15    (output-buffer :initarg :output-buffer :accessor output-buffer-of))
  16   (:default-initargs :single-channel nil))
  17 \f
  18
  19 ;;;-----------------------------------------------------------------------------
  20 ;;; Buffer Constructors
  21 ;;;-----------------------------------------------------------------------------
  22
  23 (defmethod initialize-instance :after ((buffer buffer) &key single-channel
  24                                        input-buffer-size output-buffer-size)
  25   (with-accessors ((input-buffer input-buffer-of)
  26                    (output-buffer output-buffer-of))
  27       buffer
  28     (if input-buffer
  29         (check-type input-buffer iobuf)
  30         (setf input-buffer (make-iobuf input-buffer-size)))
  31     (if single-channel
  32         (setf output-buffer input-buffer)
  33         (cond
  34           (output-buffer
  35            (check-type output-buffer iobuf)
  36            (assert (not (eq input-buffer output-buffer))))
  37           (t (setf output-buffer (make-iobuf output-buffer-size)))))))
  38 \f
  39
  40 ;;;-----------------------------------------------------------------------------
  41 ;;; Buffer Generic Functions
  42 ;;;-----------------------------------------------------------------------------
  43
  44 (defgeneric buffer-clear-input (buffer))
  45
  46 (defgeneric buffer-clear-output (buffer))
  47
  48 (defgeneric buffer-flush-output (buffer &optional timeout))
  49 \f
  50
  51 ;;;-----------------------------------------------------------------------------
  52 ;;; Buffer DEVICE-READ
  53 ;;;-----------------------------------------------------------------------------
  54
  55 (defmethod device-read ((device buffer) buffer start end &optional timeout)
  56   (when (= start end) (return-from device-read 0))
  57   (read-octets/buffered device buffer start end timeout))
  58
  59 (defun read-octets/buffered (buffer vector start end timeout)
  60   (declare (type buffer buffer)
  61            (type ub8-simple-vector vector)
  62            (type iobuf-index start end)
  63            (type device-timeout timeout))
  64   (with-accessors ((input-handle input-handle-of)
  65                    (input-buffer input-buffer-of))
  66       buffer
  67     (cond
  68       ((iobuf-empty-p input-buffer)
  69        (let ((nbytes (fill-input-buffer input-handle input-buffer timeout)))
  70          (if (iobuf-empty-p input-buffer)
  71              (if (eql :eof nbytes) :eof 0)
  72              (iobuf->vector input-buffer vector start end))))
  73       (t
  74        (iobuf->vector input-buffer vector start end)))))
  75
  76 (defun fill-input-buffer (input-handle input-buffer timeout)
  77   (multiple-value-bind (data start end)
  78       (iobuf-next-empty-zone input-buffer)
  79     (device-read input-handle data start end timeout)))
  80 \f
  81
  82 ;;;-----------------------------------------------------------------------------
  83 ;;; Buffer DEVICE-WRITE
  84 ;;;-----------------------------------------------------------------------------
  85
  86 (defmethod device-write ((device buffer) buffer start end &optional timeout)
  87   (when (= start end) (return-from device-write 0))
  88   (write-octets/buffered device buffer start end timeout))
  89
  90 (defun write-octets/buffered (buffer vector start end timeout)
  91   (declare (type buffer buffer)
  92            (type ub8-simple-vector vector)
  93            (type iobuf-index start end)
  94            (type device-timeout timeout))
  95   (with-accessors ((output-handle output-handle-of)
  96                    (output-buffer output-buffer-of))
  97       buffer
  98     (vector->iobuf output-buffer vector start end)
  99     (when (iobuf-full-p output-buffer)
 100       (flush-output-buffer output-handle output-buffer timeout))))
 101
 102 (defun flush-output-buffer (output-handle output-buffer timeout)
 103   (multiple-value-bind (data start end)
 104       (iobuf-next-data-zone output-buffer)
 105     (device-write output-handle data start end timeout)))
 106 \f
 107
 108 ;;;-----------------------------------------------------------------------------
 109 ;;; Buffer DEVICE-POSITION
 110 ;;;-----------------------------------------------------------------------------
 111
 112 (defmethod device-position ((device buffer))
 113   (when-let ((handle-position
 114               (device-position (input-handle-of device))))
 115     (+ handle-position (iobuf-available-octets (input-buffer-of device)))))
 116
 117 (defmethod (setf device-position) (position (device buffer) &key (from :start))
 118   (setf (device-position device :from from) position))
 119 \f
 120
 121 ;;;-----------------------------------------------------------------------------
 122 ;;; Buffer cleaning
 123 ;;;-----------------------------------------------------------------------------
 124
 125 (defmethod buffer-clear-input ((buffer buffer))
 126   (iobuf-reset (input-buffer-of buffer)))
 127
 128 (defmethod buffer-clear-output ((buffer buffer))
 129   (iobuf-reset (output-buffer-of buffer)))
 130
 131 (defmethod buffer-flush-output ((buffer buffer) &optional timeout)
 132   (with-accessors ((output-handle output-handle-of)
 133                    (output-buffer output-buffer-of))
 134       buffer
 135     (flush-output-buffer output-handle output-buffer timeout)
 136     (iobuf-available-octets output-buffer)))