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

   1 ;;;; -*- Mode: 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 (slot-value stream 'eol-writer)
  64           (case (babel:external-format-eol-style canonical-ef)
  65             (:lf   #'stream-write-lf)
  66             (:crlf #'stream-write-crlf)
  67             (:cr   #'stream-write-cr)))
  68     (setf (values (slot-value stream 'eol-finder)
  69                   (slot-value stream 'eol-finder/no-hang))
  70           (case (babel:external-format-eol-style canonical-ef)
  71             (:lf   (values #'stream-find-lf   #'stream-find-lf/no-hang))
  72             (:crlf (values #'stream-find-crlf #'stream-find-crlf/no-hang))
  73             (:cr   (values #'stream-find-cr   #'stream-find-cr/no-hang))))))
  74 \f
  75
  76 ;;;-------------------------------------------------------------------------
  77 ;;; Input Methods
  78 ;;;-------------------------------------------------------------------------
  79
  80 (defmethod stream-clear-input ((stream dual-channel-gray-stream))
  81   (iobuf-reset (input-buffer-of stream)))
  82
  83 (declaim (inline %read-sequence))
  84 (defun %read-sequence (stream seq start end)
  85   (check-bounds seq start end)
  86   (when (< start end)
  87     (etypecase seq
  88       (ub8-sarray (%read-into-simple-array-ub8 stream seq start end))
  89       (string     (%read-into-string stream seq start end))
  90       (ub8-vector (%read-into-vector stream seq start end)))))
  91
  92 (declaim (inline read-sequence*))
  93 (defun read-sequence* (stream sequence &key (start 0) end)
  94   (%read-sequence stream sequence start end))
  95
  96 (defmethod stream-read-sequence
  97     ((stream dual-channel-gray-stream) sequence start end &key)
  98   (%read-sequence stream sequence start end))
  99
 100 (defmethod drain-input-buffer
 101     ((stream dual-channel-gray-stream) sequence &key (start 0) end)
 102   (check-bounds sequence start end)
 103   (with-accessors ((ib input-buffer-of))
 104       stream
 105     (let ((nbytes (min (- end start)
 106                        (iobuf-length ib))))
 107       (when (plusp nbytes)
 108         (iobuf-copy-into-lisp-array ib (iobuf-start ib)
 109                                     sequence start
 110                                     nbytes)
 111         (incf (iobuf-start ib) nbytes)
 112         (let ((len (iobuf-length ib)))
 113           (values (+ start nbytes)
 114                   (and (plusp len) len)))))))
 115 \f
 116
 117 ;;;-------------------------------------------------------------------------
 118 ;;; Output Methods
 119 ;;;-------------------------------------------------------------------------
 120
 121 (defmethod stream-clear-output ((stream dual-channel-gray-stream))
 122   (iobuf-reset (output-buffer-of stream))
 123   (setf (dirtyp stream) nil))
 124
 125 (defmethod stream-finish-output ((stream dual-channel-gray-stream))
 126   (with-accessors ((fd output-fd-of)
 127                    (write-fn write-fn-of)
 128                    (ob output-buffer-of)
 129                    (dirtyp dirtyp))
 130       stream
 131     (with-hangup-guard stream
 132       (%write-octets-from-iobuf write-fn fd ob))
 133     (setf dirtyp nil)))
 134
 135 (defmethod stream-force-output ((stream dual-channel-gray-stream))
 136   (setf (dirtyp stream) t))
 137
 138 (declaim (inline %write-sequence))
 139 (defun %write-sequence (stream seq start end)
 140   (check-bounds seq start end)
 141   (when (< start end)
 142     (etypecase seq
 143       (ub8-sarray (%write-simple-array-ub8 stream seq start end))
 144       (string     (stream-write-string stream seq start end))
 145       (ub8-vector (%write-vector-ub8 stream seq start end))
 146       (vector     (%write-vector stream seq start end)))))
 147
 148 (declaim (inline write-sequence*))
 149 (defun write-sequence* (stream sequence &key (start 0) end)
 150   (%write-sequence stream sequence start end))
 151
 152 (defmethod stream-write-sequence ((stream dual-channel-gray-stream)
 153                                   sequence start end &key)
 154   (%write-sequence stream sequence start end))
 155 \f
 156
 157 ;;;-------------------------------------------------------------------------
 158 ;;; Character Input
 159 ;;;-------------------------------------------------------------------------
 160
 161 (defun %stream-rewind-iobuf (stream iobuf encoding)
 162   (maybe-rewind-iobuf iobuf encoding)
 163   (setf (unread-index-of stream) (iobuf-start iobuf)))
 164
 165 (defmethod stream-read-char ((stream dual-channel-gray-stream))
 166   (with-accessors ((fd input-fd-of)
 167                    (ib input-buffer-of)
 168                    (read-fn read-fn-of)
 169                    (unread-index unread-index-of)
 170                    (ef external-format-of))
 171       stream
 172     (let ((encoding (babel:external-format-encoding ef)))
 173       (%stream-rewind-iobuf stream ib encoding)
 174       (cond
 175         ((and (iobuf-empty-p ib)
 176               (eql :eof (%fill-ibuf ib fd read-fn)))
 177          :eof)
 178         (t
 179          ;; At this point, there's at least one octet in the buffer
 180          (debug-only (assert (not (iobuf-empty-p ib))))
 181          (let ((line-end (funcall (eol-finder-of stream) ib fd read-fn)))
 182            (if (eql #\Newline line-end)
 183                #\Newline
 184                (decode-one-char fd read-fn ib encoding))))))))
 185
 186 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream))
 187   (with-accessors ((fd input-fd-of)
 188                    (read-fn read-fn-of)
 189                    (ib input-buffer-of)
 190                    (ef external-format-of))
 191       stream
 192     (let ((encoding (babel:external-format-encoding ef)))
 193       (%stream-rewind-iobuf stream ib encoding)
 194       (when (iobuf-empty-p ib)
 195         (let ((nbytes (%fill-ibuf/no-hang ib fd read-fn)))
 196           (cond
 197             ((eql :eof nbytes) (return* :eof))
 198             ((zerop nbytes)    (return* nil)))))
 199       ;; At this point, there's at least one octet in the buffer
 200       (debug-only (assert (not (iobuf-empty-p ib))))
 201       (let ((line-end (funcall (eol-finder/no-hang-of stream) ib fd read-fn)))
 202         (case line-end
 203           ((nil) (decode-one-char/no-hang ib encoding))
 204           (#\Newline #\Newline)
 205           ;; There's a CR but it's not EOF so we could still receive a LF
 206           (:incomplete nil))))))
 207
 208 (defun %stream-unread-char (stream)
 209   (declare (type dual-channel-gray-stream stream))
 210   (with-accessors ((ib input-buffer-of)
 211                    (unread-index unread-index-of))
 212       stream
 213     (symbol-macrolet ((start (iobuf-start ib)))
 214       (cond
 215         ((> start unread-index)
 216          (setf start unread-index))
 217         ((= start unread-index)
 218          (error 'no-characters-to-unread :stream stream))
 219         (t (bug "On stream ~S the buffer start(~A) is less than the unread index(~A)."
 220                 stream start unread-index)))))
 221   nil)
 222
 223 (defmethod stream-unread-char ((stream dual-channel-gray-stream) character)
 224   (declare (ignore character))
 225   (%stream-unread-char stream))
 226
 227 (defmethod stream-peek-char ((stream dual-channel-gray-stream))
 228   (let ((char (stream-read-char stream)))
 229     (cond ((eql :eof char)
 230            :eof)
 231           (t
 232            (%stream-unread-char stream)
 233            char))))
 234
 235 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
 236 ;;   )
 237
 238 (defmethod stream-listen ((stream dual-channel-gray-stream))
 239   (let ((char (stream-read-char-no-hang stream)))
 240     (cond ((characterp char) (stream-unread-char stream char) t)
 241           ((eql :eof char) nil)
 242           (t t))))
 243 \f
 244
 245 ;;;-------------------------------------------------------------------------
 246 ;;; Character Output
 247 ;;;-------------------------------------------------------------------------
 248
 249 (defmethod stream-write-char ((stream dual-channel-gray-stream)
 250                               (character character))
 251   (%flush-obuf-if-needed stream)
 252   (if (char= character #\Newline)
 253       (funcall (eol-writer-of stream) stream)
 254       (let ((string (make-string 1 :initial-element character)))
 255         (declare (dynamic-extent string))
 256         (stream-write-string stream string))))
 257
 258 (defmethod stream-line-column ((stream dual-channel-gray-stream))
 259   0)
 260
 261 (defmethod stream-start-line-p ((stream dual-channel-gray-stream))
 262   nil)
 263
 264 (defmethod stream-terpri ((stream dual-channel-gray-stream))
 265   (write-char #\Newline stream) nil)
 266
 267 (defmethod stream-fresh-line ((stream dual-channel-gray-stream))
 268   (write-char #\Newline stream) t)
 269
 270 (defmethod stream-write-string ((stream dual-channel-gray-stream)
 271                                 (string string) &optional (start 0) end)
 272   (check-bounds string start end)
 273   (do* ((ef (external-format-of stream))
 274         (encoding (babel:external-format-encoding ef)))
 275       ((= start end))
 276     (case (char string start)
 277       (#\Newline
 278        (funcall (eol-writer-of stream) stream)
 279        (incf start))
 280       (t
 281        (setf start (%write-string-chunk stream string start end encoding)))))
 282   string)
 283 \f
 284
 285 ;;;-------------------------------------------------------------------------
 286 ;;; Binary Input
 287 ;;;-------------------------------------------------------------------------
 288
 289 (defmethod stream-read-byte ((stream dual-channel-gray-stream))
 290   (with-accessors ((fd input-fd-of)
 291                    (read-fn read-fn-of)
 292                    (ib input-buffer-of))
 293       stream
 294     (flet ((fill-buf-or-eof ()
 295              (iobuf-reset ib)
 296              (when (eql :eof (%fill-ibuf ib fd read-fn))
 297                (return* :eof))))
 298       (when (zerop (iobuf-length ib))
 299         (fill-buf-or-eof))
 300       (iobuf-pop-octet ib))))
 301 \f
 302
 303 ;;;-------------------------------------------------------------------------
 304 ;;; Binary Output
 305 ;;;-------------------------------------------------------------------------
 306
 307 (defmethod stream-write-byte ((stream dual-channel-gray-stream) integer)
 308   (check-type integer ub8 "an unsigned 8-bit value")
 309   (with-accessors ((ob output-buffer-of))
 310       stream
 311     (with-hangup-guard stream
 312       (%flush-obuf-if-needed stream))
 313     (iobuf-push-octet ob integer)))
 314 \f
 315
 316 ;;;-------------------------------------------------------------------------
 317 ;;; Buffer-related functions
 318 ;;;-------------------------------------------------------------------------
 319
 320 (defmethod input-buffer-size ((stream dual-channel-gray-stream))
 321   (iobuf-length (input-buffer-of stream)))
 322
 323 (defmethod input-buffer-empty-p ((stream dual-channel-gray-stream))
 324   (iobuf-empty-p (input-buffer-of stream)))
 325
 326 (defmethod output-buffer-size ((stream dual-channel-gray-stream))
 327   (iobuf-length (output-buffer-of stream)))
 328
 329 (defmethod output-buffer-empty-p ((stream dual-channel-gray-stream))
 330   (iobuf-empty-p (output-buffer-of stream)))