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