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