src/streams/gray/gray-stream-methods.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Implementation using Gray streams.
   4 ;;;
   5
   6 (in-package :iolib.streams)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Instance Initialization
  10 ;;;-------------------------------------------------------------------------
  11
  12 (defun free-stream-buffers (ibuf obuf)
  13   (when ibuf (free-iobuf ibuf))
  14   (when obuf (free-iobuf obuf)))
  15
  16 ;;; TODO: use the buffer pool
  17 ;;; TODO: handle instance reinitialization
  18 (defmethod shared-initialize :after ((stream dual-channel-gray-stream) slot-names
  19                                      &key (input-buffer-size +bytes-per-iobuf+)
  20                                      (output-buffer-size +bytes-per-iobuf+)
  21                                      (external-format :default))
  22   (declare (ignore slot-names))
  23   (unless input-buffer-size (setf input-buffer-size +bytes-per-iobuf+))
  24   (unless output-buffer-size (setf output-buffer-size +bytes-per-iobuf+))
  25   (check-type input-buffer-size buffer-index)
  26   (check-type output-buffer-size buffer-index)
  27   (with-accessors ((ibuf input-buffer-of)
  28                    (obuf output-buffer-of)
  29                    (ef external-format-of))
  30       stream
  31     (setf ibuf (allocate-iobuf input-buffer-size)
  32           obuf (allocate-iobuf output-buffer-size)
  33           ef external-format)
  34     (trivial-garbage:finalize stream (lambda () (free-stream-buffers ibuf obuf)))))
  35 \f
  36
  37 ;;;-------------------------------------------------------------------------
  38 ;;; Common Methods
  39 ;;;-------------------------------------------------------------------------
  40
  41 (defmethod stream-element-type ((stream dual-channel-gray-stream))
  42   '(unsigned-byte 8))
  43
  44 ;; TODO: use the buffer pool
  45 (defmethod close :around ((stream dual-channel-gray-stream) &key abort)
  46   (with-accessors ((ibuf input-buffer-of)
  47                    (obuf output-buffer-of))
  48       stream
  49     (trivial-garbage:cancel-finalization stream)
  50     (unless (or abort (null ibuf)) (finish-output stream))
  51     (free-stream-buffers ibuf obuf)
  52     (setf ibuf nil obuf nil))
  53   (call-next-method)
  54   stream)
  55
  56 (defmethod close ((stream dual-channel-gray-stream) &key abort)
  57   (declare (ignore stream abort)))
  58
  59 (defmethod (setf external-format-of)
  60     (external-format (stream dual-channel-gray-stream))
  61   (let ((canonical-ef (babel:ensure-external-format external-format)))
  62     (setf (slot-value stream 'external-format) canonical-ef)
  63     (setf (values (slot-value stream 'eol-writer)
  64                   (slot-value stream 'eol-finder))
  65           (case (babel:external-format-eol-style canonical-ef)
  66             (:lf   (values #'stream-write-lf   #'stream-find-lf))
  67             (:crlf (values #'stream-write-crlf #'stream-find-crlf))
  68             (:cr   (values #'stream-write-cr   #'stream-find-cr))))))
  69 \f
  70
  71 ;;;-------------------------------------------------------------------------
  72 ;;; Input Methods
  73 ;;;-------------------------------------------------------------------------
  74
  75 (defmethod stream-clear-input ((stream dual-channel-gray-stream))
  76   (iobuf-reset (input-buffer-of stream)))
  77
  78 (declaim (inline %read-sequence))
  79 (defun %read-sequence (stream seq start end)
  80   (check-bounds seq start end)
  81   (when (< start end)
  82     (etypecase seq
  83       (ub8-sarray (%read-into-simple-array-ub8 stream seq start end))
  84       (string     (%read-into-string stream seq start end))
  85       (ub8-vector (%read-into-vector stream seq start end)))))
  86
  87 (declaim (inline read-sequence*))
  88 (defun read-sequence* (stream sequence &key (start 0) end)
  89   (%read-sequence stream sequence start end))
  90
  91 (defmethod stream-read-sequence
  92     ((stream dual-channel-gray-stream) sequence start end &key)
  93   (%read-sequence stream sequence start end))
  94
  95 (defmethod drain-input-buffer
  96     ((stream dual-channel-gray-stream) sequence &key (start 0) end)
  97   (check-bounds sequence start end)
  98   (with-accessors ((ib input-buffer-of))
  99       stream
 100     (let ((nbytes (min (- end start)
 101                        (iobuf-length ib))))
 102       (when (plusp nbytes)
 103         (iobuf-copy-into-lisp-array ib (iobuf-start ib)
 104                                     sequence start
 105                                     nbytes)
 106         (incf (iobuf-start ib) nbytes)
 107         (let ((len (iobuf-length ib)))
 108           (values (+ start nbytes)
 109                   (and (plusp len) len)))))))
 110 \f
 111
 112 ;;;-------------------------------------------------------------------------
 113 ;;; Output Methods
 114 ;;;-------------------------------------------------------------------------
 115
 116 (defmethod stream-clear-output ((stream dual-channel-gray-stream))
 117   (iobuf-reset (output-buffer-of stream))
 118   (setf (dirtyp stream) nil))
 119
 120 (defmethod stream-finish-output ((stream dual-channel-gray-stream))
 121   (with-accessors ((fd output-fd-of)
 122                    (write-fn write-fn-of)
 123                    (ob output-buffer-of)
 124                    (dirtyp dirtyp))
 125       stream
 126     (with-hangup-guard stream
 127       (%write-octets-from-iobuf write-fn fd ob))
 128     (setf dirtyp nil)))
 129
 130 (defmethod stream-force-output ((stream dual-channel-gray-stream))
 131   (setf (dirtyp stream) t))
 132
 133 (declaim (inline %write-sequence))
 134 (defun %write-sequence (stream seq start end)
 135   (check-bounds seq start end)
 136   (when (< start end)
 137     (etypecase seq
 138       (ub8-sarray (%write-simple-array-ub8 stream seq start end))
 139       (string     (stream-write-string stream seq start end))
 140       (ub8-vector (%write-vector-ub8 stream seq start end))
 141       (vector     (%write-vector stream seq start end)))))
 142
 143 (declaim (inline write-sequence*))
 144 (defun write-sequence* (stream sequence &key (start 0) end)
 145   (%write-sequence stream sequence start end))
 146
 147 (defmethod stream-write-sequence ((stream dual-channel-gray-stream)
 148                                   sequence start end &key)
 149   (%write-sequence stream sequence start end))
 150 \f
 151
 152 ;;;-------------------------------------------------------------------------
 153 ;;; Character Input
 154 ;;;-------------------------------------------------------------------------
 155
 156 (defun %stream-rewind-iobuf (stream iobuf encoding)
 157   (maybe-rewind-iobuf iobuf encoding)
 158   (setf (unread-index-of stream) (iobuf-start iobuf)))
 159
 160 (defmethod stream-read-char ((stream dual-channel-gray-stream))
 161   (with-accessors ((fd input-fd-of)
 162                    (ib input-buffer-of)
 163                    (read-fn read-fn-of)
 164                    (unread-index unread-index-of)
 165                    (ef external-format-of))
 166       stream
 167     (let ((encoding (babel:external-format-encoding ef)))
 168       (%stream-rewind-iobuf stream ib encoding)
 169       (let ((eofp (eql :eof (%fill-ibuf ib fd read-fn))))
 170         (if (and eofp (iobuf-empty-p ib))
 171             :eof
 172             ;; At this point, there's at least one octet in the buffer
 173             (let ((line-end (funcall (eol-finder-of stream) ib fd read-fn nil eofp)))
 174               (if (eql #\Newline line-end)
 175                   #\Newline
 176                   (decode-one-char fd read-fn ib encoding))))))))
 177
 178 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream))
 179   (with-accessors ((fd input-fd-of)
 180                    (read-fn read-fn-of)
 181                    (ib input-buffer-of)
 182                    (ef external-format-of))
 183       stream
 184     (let ((encoding (babel:external-format-encoding ef)))
 185       (%stream-rewind-iobuf stream ib encoding)
 186       (let ((eofp (eql :eof (%fill-ibuf/no-hang ib fd read-fn))))
 187         (if (iobuf-empty-p ib)
 188             (if eofp :eof nil)
 189             ;; At this point, there's at least one octet in the buffer
 190             (let ((line-end (funcall (eol-finder-of stream) ib fd read-fn t eofp)))
 191               (cond (;; There's a CR but it's not EOF so we could still receive a LF
 192                      (and (eql :incomplete line-end) (not eofp))
 193                      nil)
 194                     ((eql #\Newline line-end)
 195                      #\Newline)
 196                     (t
 197                      (decode-one-char/no-hang ib encoding)))))))))
 198
 199 (defun %stream-unread-char (stream)
 200   (declare (type dual-channel-gray-stream stream))
 201   (with-accessors ((ib input-buffer-of)
 202                    (unread-index unread-index-of))
 203       stream
 204     (symbol-macrolet ((start (iobuf-start ib)))
 205       (cond
 206         ((> start unread-index)
 207          (setf start unread-index))
 208         ((= start unread-index)
 209          (error 'no-characters-to-unread :stream stream))
 210         (t (bug "On stream ~S the buffer start(~A) is less than the unread index(~A)."
 211                 stream start unread-index)))))
 212   nil)
 213
 214 (defmethod stream-unread-char ((stream dual-channel-gray-stream) character)
 215   (declare (ignore character))
 216   (%stream-unread-char stream))
 217
 218 (defmethod stream-peek-char ((stream dual-channel-gray-stream))
 219   (let ((char (stream-read-char stream)))
 220     (cond ((eql :eof char)
 221            :eof)
 222           (t
 223            (%stream-unread-char stream)
 224            char))))
 225
 226 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
 227 ;;   )
 228
 229 (defmethod stream-listen ((stream dual-channel-gray-stream))
 230   (let ((char (stream-read-char-no-hang stream)))
 231     (cond ((characterp char) (stream-unread-char stream char) t)
 232           ((eql :eof char) nil)
 233           (t t))))
 234 \f
 235
 236 ;;;-------------------------------------------------------------------------
 237 ;;; Character Output
 238 ;;;-------------------------------------------------------------------------
 239
 240 (defmethod stream-write-char ((stream dual-channel-gray-stream)
 241                               (character character))
 242   (%flush-obuf-if-needed stream)
 243   (if (char= character #\Newline)
 244       (funcall (eol-writer-of stream) stream)
 245       (let ((string (make-string 1 :initial-element character)))
 246         (declare (dynamic-extent string))
 247         (stream-write-string stream string))))
 248
 249 (defmethod stream-line-column ((stream dual-channel-gray-stream))
 250   0)
 251
 252 (defmethod stream-start-line-p ((stream dual-channel-gray-stream))
 253   nil)
 254
 255 (defmethod stream-terpri ((stream dual-channel-gray-stream))
 256   (write-char #\Newline stream) nil)
 257
 258 (defmethod stream-fresh-line ((stream dual-channel-gray-stream))
 259   (write-char #\Newline stream) t)
 260
 261 (defmethod stream-write-string ((stream dual-channel-gray-stream)
 262                                 (string string) &optional (start 0) end)
 263   (check-bounds string start end)
 264   (do* ((ef (external-format-of stream))
 265         (encoding (babel:external-format-encoding ef)))
 266       ((= start end))
 267     (case (char string start)
 268       (#\Newline
 269        (funcall (eol-writer-of stream) stream)
 270        (incf start))
 271       (t
 272        (setf start (%write-string-chunk stream string start end encoding)))))
 273   string)
 274 \f
 275
 276 ;;;-------------------------------------------------------------------------
 277 ;;; Binary Input
 278 ;;;-------------------------------------------------------------------------
 279
 280 (defmethod stream-read-byte ((stream dual-channel-gray-stream))
 281   (with-accessors ((fd input-fd-of)
 282                    (read-fn read-fn-of)
 283                    (ib input-buffer-of))
 284       stream
 285     (flet ((fill-buf-or-eof ()
 286              (iobuf-reset ib)
 287              (when (eql :eof (%fill-ibuf ib fd read-fn))
 288                (return* :eof))))
 289       (when (zerop (iobuf-length ib))
 290         (fill-buf-or-eof))
 291       (iobuf-pop-octet ib))))
 292 \f
 293
 294 ;;;-------------------------------------------------------------------------
 295 ;;; Binary Output
 296 ;;;-------------------------------------------------------------------------
 297
 298 (defmethod stream-write-byte ((stream dual-channel-gray-stream) integer)
 299   (check-type integer ub8 "an unsigned 8-bit value")
 300   (with-accessors ((ob output-buffer-of))
 301       stream
 302     (with-hangup-guard stream
 303       (%flush-obuf-if-needed stream))
 304     (iobuf-push-octet ob integer)))
 305 \f
 306
 307 ;;;-------------------------------------------------------------------------
 308 ;;; Buffer-related functions
 309 ;;;-------------------------------------------------------------------------
 310
 311 (defmethod input-buffer-size ((stream dual-channel-gray-stream))
 312   (iobuf-length (input-buffer-of stream)))
 313
 314 (defmethod input-buffer-empty-p ((stream dual-channel-gray-stream))
 315   (iobuf-empty-p (input-buffer-of stream)))
 316
 317 (defmethod output-buffer-size ((stream dual-channel-gray-stream))
 318   (iobuf-length (output-buffer-of stream)))
 319
 320 (defmethod output-buffer-empty-p ((stream dual-channel-gray-stream))
 321   (iobuf-empty-p (output-buffer-of stream)))