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      (trivial-garbage:finalize stream (lambda () (free-stream-buffers ibuf obuf))))))
  34 \f
  35
  36 ;;;-------------------------------------------------------------------------
  37 ;;; PRINT-OBJECT
  38 ;;;-------------------------------------------------------------------------
  39
  40 (defmethod print-object ((o dual-channel-gray-stream) s)
  41   (with-slots (fd (ef external-format) (ib input-buffer) (ob output-buffer))
  42       o
  43     (print-unreadable-object (o s :type nil :identity t)
  44       (if fd
  45           (format s "~A ~S ~S ~S ~S/~S ~S ~S/~S ~S (~S ~S ~S)"
  46                   (type-of o) :fd fd
  47                   :ibuf (iobuf-length ib) (iobuf-size ib)
  48                   :obuf (iobuf-length ob) (iobuf-size ob)
  49                   :ef (babel-encodings:enc-name (babel:external-format-encoding ef))
  50                   :eol-style (babel:external-format-eol-style ef))
  51           (format s "~A ~A ~S (~S ~S ~S)"
  52                   (type-of o) :closed
  53                   :ef (babel-encodings:enc-name (babel:external-format-encoding ef))
  54                   :eol-style (babel:external-format-eol-style ef))))))
  55 \f
  56
  57 ;;;-------------------------------------------------------------------------
  58 ;;; Common Methods
  59 ;;;-------------------------------------------------------------------------
  60
  61 (defmethod stream-element-type ((stream dual-channel-gray-stream))
  62   '(unsigned-byte 8))
  63
  64 ;; TODO: use the buffer pool
  65 (defmethod close :around ((stream dual-channel-gray-stream) &key abort)
  66   (with-accessors ((ibuf input-buffer-of)
  67                    (obuf output-buffer-of))
  68       stream
  69     (trivial-garbage:cancel-finalization stream)
  70     (unless (or abort (null ibuf)) (finish-output stream))
  71     (free-stream-buffers ibuf obuf)
  72     (setf ibuf nil obuf nil))
  73   (call-next-method))
  74
  75 (defmethod (setf external-format-of)
  76     (external-format (stream dual-channel-gray-stream))
  77   (let ((canonical-ef (babel:ensure-external-format external-format)))
  78     (setf (slot-value stream 'external-format) canonical-ef)
  79     (setf (slot-value stream 'eol-writer)
  80           (case (babel:external-format-eol-style canonical-ef)
  81             (:lf   #'stream-write-lf)
  82             (:crlf #'stream-write-crlf)
  83             (:cr   #'stream-write-cr)))
  84     (setf (values (slot-value stream 'eol-finder)
  85                   (slot-value stream 'eol-finder/no-hang))
  86           (case (babel:external-format-eol-style canonical-ef)
  87             (:lf   (values #'stream-find-lf   #'stream-find-lf/no-hang))
  88             (:crlf (values #'stream-find-crlf #'stream-find-crlf/no-hang))
  89             (:cr   (values #'stream-find-cr   #'stream-find-cr/no-hang))))))
  90 \f
  91
  92 ;;;-------------------------------------------------------------------------
  93 ;;; Input Methods
  94 ;;;-------------------------------------------------------------------------
  95
  96 (defmethod stream-clear-input ((stream dual-channel-gray-stream))
  97   (iobuf-reset (input-buffer-of stream)))
  98
  99 (declaim (inline %read-sequence))
 100 (defun %read-sequence (stream seq start end)
 101   (check-bounds seq start end)
 102   (if (< start end)
 103     (etypecase seq
 104       (ub8-sarray (%read-into-simple-array-ub8 stream seq start end))
 105       (string     (%read-into-string stream seq start end))
 106       (ub8-vector (%read-into-vector stream seq start end)))
 107     start))
 108
 109 (declaim (inline read-sequence*))
 110 (defun read-sequence* (stream sequence &key (start 0) end)
 111   (%read-sequence stream sequence start end))
 112
 113 (defmethod stream-read-sequence
 114     ((stream dual-channel-gray-stream) sequence start end &key)
 115   (%read-sequence stream sequence start end))
 116
 117 (defmethod drain-input-buffer
 118     ((stream dual-channel-gray-stream) sequence &key (start 0) end)
 119   (check-bounds sequence start end)
 120   (with-accessors ((ib input-buffer-of))
 121       stream
 122     (let ((nbytes (min (- end start)
 123                        (iobuf-length ib))))
 124       (when (plusp nbytes)
 125         (iobuf-copy-into-lisp-array ib (iobuf-start ib)
 126                                     sequence start
 127                                     nbytes)
 128         (incf (iobuf-start ib) nbytes)
 129         (let ((len (iobuf-length ib)))
 130           (values (+ start nbytes)
 131                   (and (plusp len) len)))))))
 132 \f
 133
 134 ;;;-------------------------------------------------------------------------
 135 ;;; Output Methods
 136 ;;;-------------------------------------------------------------------------
 137
 138 (defmethod stream-clear-output ((stream dual-channel-gray-stream))
 139   (iobuf-reset (output-buffer-of stream))
 140   (setf (dirtyp stream) nil))
 141
 142 (defmethod stream-finish-output ((stream dual-channel-gray-stream))
 143   (with-accessors ((fd fd-of)
 144                    (write-fn write-fn-of)
 145                    (ob output-buffer-of)
 146                    (dirtyp dirtyp))
 147       stream
 148     (with-hangup-guard stream
 149       (%write-octets-from-iobuf write-fn fd ob))
 150     (setf dirtyp nil)))
 151
 152 (defmethod stream-force-output ((stream dual-channel-gray-stream))
 153   (with-accessors ((fd fd-of)
 154                    (write-fn write-fn-of)
 155                    (ob output-buffer-of)
 156                    (dirtyp dirtyp))
 157       stream
 158     (with-hangup-guard stream
 159       (%write-octets-from-iobuf write-fn fd ob t))
 160     (unless (iobuf-empty-p ob)
 161       (setf dirtyp t))))
 162
 163 (declaim (inline %write-sequence))
 164 (defun %write-sequence (stream seq start end)
 165   (check-bounds seq start end)
 166   (when (< start end)
 167     (etypecase seq
 168       (ub8-sarray (%write-simple-array-ub8 stream seq start end))
 169       (string     (stream-write-string stream seq start end))
 170       (ub8-vector (%write-vector-ub8 stream seq start end))
 171       (vector     (%write-vector stream seq start end)))))
 172
 173 (declaim (inline write-sequence*))
 174 (defun write-sequence* (stream sequence &key (start 0) end)
 175   (%write-sequence stream sequence start end))
 176
 177 (defmethod stream-write-sequence ((stream dual-channel-gray-stream)
 178                                   sequence start end &key)
 179   (%write-sequence stream sequence start end))
 180 \f
 181
 182 ;;;-------------------------------------------------------------------------
 183 ;;; Character Input
 184 ;;;-------------------------------------------------------------------------
 185
 186 (defun %stream-rewind-iobuf (stream iobuf encoding)
 187   (maybe-rewind-iobuf iobuf encoding)
 188   (setf (unread-index-of stream) (iobuf-start iobuf)))
 189
 190 (defmethod stream-read-char ((stream dual-channel-gray-stream))
 191   (with-accessors ((fd fd-of)
 192                    (ib input-buffer-of)
 193                    (read-fn read-fn-of)
 194                    (unread-index unread-index-of)
 195                    (ef external-format-of))
 196       stream
 197     (let ((encoding (babel:external-format-encoding ef)))
 198       (%stream-rewind-iobuf stream ib encoding)
 199       (cond
 200         ((and (iobuf-empty-p ib)
 201               (eql :eof (%fill-ibuf ib fd read-fn)))
 202          :eof)
 203         (t
 204          ;; At this point, there's at least one octet in the buffer
 205          (debug-only (assert (not (iobuf-empty-p ib))))
 206          (let ((line-end (funcall (eol-finder-of stream) ib fd read-fn)))
 207            (if (eql #\Newline line-end)
 208                #\Newline
 209                (decode-one-char fd read-fn ib encoding))))))))
 210
 211 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream))
 212   (with-accessors ((fd fd-of)
 213                    (read-fn read-fn-of)
 214                    (ib input-buffer-of)
 215                    (ef external-format-of))
 216       stream
 217     (let ((encoding (babel:external-format-encoding ef)))
 218       (%stream-rewind-iobuf stream ib encoding)
 219       (when (iobuf-empty-p ib)
 220         (let ((nbytes (%fill-ibuf/no-hang ib fd read-fn)))
 221           (cond
 222             ((eql :eof nbytes) (return* :eof))
 223             ((zerop nbytes)    (return* nil)))))
 224       ;; At this point, there's at least one octet in the buffer
 225       (debug-only (assert (not (iobuf-empty-p ib))))
 226       (let ((line-end (funcall (eol-finder/no-hang-of stream) ib fd read-fn)))
 227         (case line-end
 228           ((nil) (decode-one-char/no-hang ib encoding))
 229           (#\Newline #\Newline)
 230           ;; There's a CR but it's not EOF so we could still receive a LF
 231           (:incomplete nil))))))
 232
 233 (defun %stream-unread-char (stream)
 234   (declare (type dual-channel-gray-stream stream))
 235   (with-accessors ((ib input-buffer-of)
 236                    (unread-index unread-index-of))
 237       stream
 238     (symbol-macrolet ((start (iobuf-start ib)))
 239       (cond
 240         ((> start unread-index)
 241          (setf start unread-index))
 242         ((= start unread-index)
 243          (error 'no-characters-to-unread :stream stream))
 244         (t (bug "On stream ~S the buffer start(~A) is less than the unread index(~A)."
 245                 stream start unread-index)))))
 246   nil)
 247
 248 (defmethod stream-unread-char ((stream dual-channel-gray-stream) character)
 249   (declare (ignore character))
 250   (%stream-unread-char stream))
 251
 252 (defmethod stream-peek-char ((stream dual-channel-gray-stream))
 253   (let ((char (stream-read-char stream)))
 254     (cond ((eql :eof char)
 255            :eof)
 256           (t
 257            (%stream-unread-char stream)
 258            char))))
 259
 260 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
 261 ;;   )
 262
 263 (defmethod stream-listen ((stream dual-channel-gray-stream))
 264   (let ((char (stream-read-char-no-hang stream)))
 265     (cond ((characterp char) (stream-unread-char stream char) t)
 266           ((eql :eof char) nil)
 267           (t t))))
 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)))