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 ;;;; Instance Initialization
   9
  10 (defun free-stream-buffers (ib ob)
  11   (when ib (free-iobuf ib))
  12   (when ob (free-iobuf ob)))
  13
  14 ;;; TODO: use the buffer pool
  15 ;;; TODO: handle instance reinitialization
  16 (defmethod shared-initialize :after ((stream dual-channel-gray-stream) slot-names
  17                                      &key (input-buffer-size +bytes-per-iobuf+)
  18                                      (output-buffer-size +bytes-per-iobuf+)
  19                                      (external-format :default))
  20   (declare (ignore slot-names))
  21   (unless input-buffer-size (setf input-buffer-size +bytes-per-iobuf+))
  22   (unless output-buffer-size (setf output-buffer-size +bytes-per-iobuf+))
  23   (check-type input-buffer-size buffer-index)
  24   (check-type output-buffer-size buffer-index)
  25   (with-accessors ((ib input-buffer-of)
  26                    (ob output-buffer-of)
  27                    (ef external-format-of))
  28       stream
  29     (setf ib (allocate-iobuf input-buffer-size)
  30           ob (allocate-iobuf output-buffer-size)
  31           ef external-format)
  32     (trivial-garbage:finalize stream (lambda () (free-stream-buffers ib ob)))))
  33
  34 ;;;; Common Methods
  35
  36 (defmethod stream-element-type ((stream dual-channel-gray-stream))
  37   '(unsigned-byte 8))
  38
  39 ;; TODO: use the buffer pool
  40 (defmethod close :around ((stream dual-channel-gray-stream) &key abort)
  41   (with-accessors ((ib input-buffer-of)
  42                    (ob output-buffer-of))
  43       stream
  44     (trivial-garbage:cancel-finalization stream)
  45     (unless (or abort (null ib)) (finish-output stream))
  46     (free-stream-buffers ib ob)
  47     (setf ib nil ob nil))
  48   (call-next-method)
  49   (values stream))
  50
  51 (defmethod close ((stream dual-channel-gray-stream) &key abort)
  52   (declare (ignore stream abort)))
  53
  54 (defmethod (setf external-format-of)
  55     (external-format (stream dual-channel-gray-stream))
  56   (setf (slot-value stream 'external-format)
  57         (babel:ensure-external-format external-format)))
  58
  59 ;;;; Input Methods
  60
  61 (defun %to-octets (buff start end ef)
  62   (babel:string-to-octets buff :start start :end end
  63                           :encoding (babel:external-format-encoding ef)))
  64
  65 (defmethod stream-clear-input ((stream dual-channel-gray-stream))
  66   (with-accessors ((ib input-buffer-of))
  67       stream
  68     (iobuf-reset ib)
  69     nil))
  70
  71 (defun %fill-ibuf (read-fn fd buf)
  72   (flet ((read-once ()
  73            (loop
  74              (handler-case
  75                  (return-from read-once
  76                    (funcall read-fn fd (iobuf-end-pointer buf)
  77                             (iobuf-end-space-length buf)))
  78                (isys:eintr ())
  79                (isys:ewouldblock (err)
  80                  (if (%get-fd-nonblock-mode fd)
  81                      (iomux:wait-until-fd-ready fd :input nil t)
  82                        ;; FIXME: big kludge.
  83                        ;; the only way to get EWOULDBLOCK on a blocking socket
  84                        ;; is when the user has set the RCV_TIMEO option, so
  85                        ;; the error object must be resignaled
  86                      (error err)))))))
  87     (let ((nbytes (read-once)))
  88       (if (zerop nbytes)
  89           :eof
  90           (incf (iobuf-end buf) nbytes)))))
  91
  92 (defun %read-into-simple-array-ub8 (stream array start end)
  93   (declare (type dual-channel-gray-stream stream))
  94   (with-accessors ((ib input-buffer-of)
  95                    (fd input-fd-of)
  96                    (read-fn read-fn-of))
  97       stream
  98     (let ((octets-needed (- end start)))
  99       (loop :with array-offset := start
 100             :for octets-in-buffer := (iobuf-length ib)
 101             :for nbytes := (min octets-needed octets-in-buffer)
 102          :when (plusp nbytes) :do
 103            (iobuf-copy-into-lisp-array ib (iobuf-start ib)
 104                                        array array-offset nbytes)
 105            (incf array-offset nbytes)
 106            (decf octets-needed nbytes)
 107            (incf (iobuf-start ib) nbytes)
 108          :if (zerop octets-needed) :do (loop-finish)
 109          :else :do (iobuf-reset ib)
 110          :when (eql :eof (%fill-ibuf read-fn fd ib)) :do (loop-finish)
 111          :finally (return array-offset)))))
 112
 113 (defun %read-into-string (stream string start end)
 114   (declare (type dual-channel-gray-stream stream))
 115   (loop :for offset :from start :below end
 116         :for char := (stream-read-char stream)
 117      :if (eql :eof char) :do (loop-finish)
 118      :else :do (setf (char string offset) char)
 119      :finally (return offset)))
 120
 121 (defun %read-into-vector (stream vector start end)
 122   (declare (type dual-channel-gray-stream stream))
 123   (loop :for offset :from start :below end
 124         :for octet := (stream-read-byte stream)
 125      :if (eql :eof octet) :do (loop-finish)
 126      :else :do (setf (aref vector offset) octet)
 127      :finally (return offset)))
 128
 129 (declaim (inline %read-sequence))
 130 (defun %read-sequence (stream seq start end)
 131   (check-bounds seq start end)
 132   (when (< start end)
 133     (etypecase seq
 134       (ub8-sarray (%read-into-simple-array-ub8 stream seq start end))
 135       (string (%read-into-string stream seq start end))
 136       (ub8-vector (%read-into-vector stream seq start end)))))
 137
 138 (declaim (inline read-sequence*))
 139 (defun read-sequence* (stream sequence &key (start 0) end)
 140   (%read-sequence stream sequence start end))
 141
 142 (defmethod stream-read-sequence
 143     ((stream dual-channel-gray-stream) sequence start end &key)
 144   (%read-sequence stream sequence start end))
 145
 146 (defmethod drain-input-buffer
 147     ((stream dual-channel-gray-stream) sequence &key (start 0) end)
 148   (check-bounds sequence start end)
 149   (with-accessors ((ib input-buffer-of))
 150       stream
 151     (let ((nbytes (min (- end start)
 152                        (iobuf-length ib))))
 153       (when (plusp nbytes)
 154         (iobuf-copy-into-lisp-array ib (iobuf-start ib)
 155                                     sequence start
 156                                     nbytes)
 157         (incf (iobuf-start ib) nbytes)
 158         (let ((len (iobuf-length ib)))
 159           (values (+ start nbytes)
 160                   (and (plusp len) len)))))))
 161
 162 ;;;; Output Methods
 163
 164 (defun %write-octets-from-foreign-memory (write-fn fd buf nbytes)
 165   (declare (type stream-buffer buf))
 166   (let ((bytes-written 0))
 167     (labels ((write-once ()
 168                (handler-case
 169                    (funcall write-fn fd (inc-pointer buf bytes-written)
 170                             (- nbytes bytes-written))
 171                  (isys:eintr ())
 172                  (isys:epipe ()
 173                    (return* (values bytes-written :hangup)))
 174                  (isys:ewouldblock (err)
 175                    (if (%get-fd-nonblock-mode fd)
 176                        (iomux:wait-until-fd-ready fd :output nil t)
 177                        ;; FIXME: big kludge.
 178                        ;; the only way to get EWOULDBLOCK on a blocking socket
 179                        ;; is when the user has set the SND_TIMEO option, so
 180                        ;; the error object must be resignaled
 181                        (error err)))
 182                  (:no-error (nbytes) (incf bytes-written nbytes))))
 183              (buffer-emptyp () (= bytes-written nbytes)))
 184       (loop :until (buffer-emptyp) :do (write-once)
 185          :finally (return* bytes-written)))))
 186
 187 (defun %write-octets-from-iobuf (write-fn fd buf)
 188   (declare (type iobuf buf))
 189   (multiple-value-bind (bytes-written hangup-p)
 190       (%write-octets-from-foreign-memory
 191        write-fn fd (iobuf-start-pointer buf) (iobuf-length buf))
 192     (incf (iobuf-start buf) bytes-written)
 193     (when (iobuf-empty-p buf) (iobuf-reset buf))
 194     (values bytes-written hangup-p)))
 195
 196 (defun flush-obuf-if-needed (stream)
 197   (declare (type dual-channel-gray-stream stream))
 198   (with-accessors ((fd output-fd-of)
 199                    (write-fn write-fn-of)
 200                    (ob output-buffer-of)
 201                    (dirtyp dirtyp))
 202       stream
 203     (when (or dirtyp (iobuf-full-p ob))
 204       (multiple-value-bind (bytes-written hangup-p)
 205           (%write-octets-from-iobuf write-fn fd ob)
 206         (setf dirtyp nil)
 207         (return* (values bytes-written hangup-p))))
 208     (values 0)))
 209
 210 (defmacro with-hangup-guard (stream &body body)
 211   (with-gensyms (bytes-written hangup-p)
 212     `(multiple-value-bind (,bytes-written ,hangup-p)
 213          (progn ,@body)
 214        (declare (ignore ,bytes-written))
 215        (when (eql :hangup ,hangup-p)
 216          (error 'hangup :stream ,stream)))))
 217
 218 (defmethod stream-clear-output ((stream dual-channel-gray-stream))
 219   (with-accessors ((ob output-buffer-of)
 220                    (dirtyp dirtyp))
 221       stream
 222     (iobuf-reset ob)
 223     (setf dirtyp nil)
 224     nil))
 225
 226 (defmethod stream-finish-output ((stream dual-channel-gray-stream))
 227   (with-accessors ((fd output-fd-of)
 228                    (write-fn write-fn-of)
 229                    (ob output-buffer-of)
 230                    (dirtyp dirtyp))
 231       stream
 232     (with-hangup-guard stream
 233       (%write-octets-from-iobuf write-fn fd ob))
 234     (setf dirtyp nil)))
 235
 236 (defmethod stream-force-output ((stream dual-channel-gray-stream))
 237   (setf (dirtyp stream) t))
 238
 239 (defun %write-simple-array-ub8 (stream array start end)
 240   (declare (type dual-channel-gray-stream stream))
 241   (with-accessors ((fd output-fd-of)
 242                    (write-fn write-fn-of)
 243                    (ob output-buffer-of))
 244       stream
 245     (let ((octets-needed (- end start)))
 246       (cond ((<= octets-needed (iobuf-end-space-length ob))
 247              (iobuf-copy-from-lisp-array array start ob
 248                                          (iobuf-end ob) octets-needed)
 249              (incf (iobuf-end ob) octets-needed)
 250              (with-hangup-guard stream
 251                (flush-obuf-if-needed stream)))
 252             (t
 253              (with-pointer-to-vector-data (ptr array)
 254                (with-hangup-guard stream
 255                  (%write-octets-from-iobuf write-fn fd ob))
 256                (with-hangup-guard stream
 257                  (%write-octets-from-foreign-memory
 258                   write-fn fd (inc-pointer ptr start) octets-needed)))))
 259       (values array))))
 260
 261 (defun %write-vector-ub8 (stream vector start end)
 262   (declare (type dual-channel-gray-stream stream))
 263   (%write-simple-array-ub8 stream (coerce vector 'ub8-sarray) start end))
 264
 265 (defun %write-vector (stream vector start end)
 266   (declare (type dual-channel-gray-stream stream))
 267   (loop :for offset :from start :below end
 268         :for octet := (aref vector offset)
 269      :do (stream-write-byte stream octet)
 270      :finally (return vector)))
 271
 272 (declaim (inline %write-sequence))
 273 (defun %write-sequence (stream seq start end)
 274   (check-bounds seq start end)
 275   (when (< start end)
 276     (etypecase seq
 277       (ub8-sarray (%write-simple-array-ub8 stream seq start end))
 278       (string (stream-write-string stream seq start end))
 279       (ub8-vector (%write-vector-ub8 stream seq start end))
 280       (vector (%write-vector stream seq start end)))))
 281
 282 (declaim (inline write-sequence*))
 283 (defun write-sequence* (stream sequence &key (start 0) end)
 284   (%write-sequence stream sequence start end))
 285
 286 (defmethod stream-write-sequence ((stream dual-channel-gray-stream)
 287                                   sequence start end &key)
 288   (%write-sequence stream sequence start end))
 289
 290 ;;;; Character Input
 291
 292 (defun maybe-find-line-ending (read-fn fd ib ef)
 293   (let* ((start-off (iobuf-start ib))
 294          (char-code (bref ib start-off)))
 295     (ecase (babel:external-format-eol-style ef)
 296       (:lf (when (= char-code (char-code #\Linefeed))
 297              (incf (iobuf-start ib))
 298              (return* #\Newline)))
 299       (:cr (when (= char-code (char-code #\Return))
 300              (incf (iobuf-start ib))
 301              (return* #\Newline)))
 302       (:crlf (when (= char-code (char-code #\Return))
 303                (when (and (= 1 (iobuf-length ib))
 304                           (eql :eof (%fill-ibuf read-fn fd ib)))
 305                  (incf (iobuf-start ib))
 306                  (return* #\Return))
 307                (when (= (bref ib (1+ start-off))
 308                         (char-code #\Linefeed))
 309                  (incf (iobuf-start ib) 2)
 310                  (return* #\Newline)))))))
 311
 312 ;;; FIXME: currently we return :EOF when read(2) returns 0
 313 ;;;        we should distinguish hard end-of-files (EOF and buffer empty)
 314 ;;;        from soft end-of-files (EOF and *some* bytes still in the buffer
 315 ;;;        but not enough to make a full character)
 316 (defmethod stream-read-char ((stream dual-channel-gray-stream))
 317   (with-accessors ((fd input-fd-of)
 318                    (ib input-buffer-of)
 319                    (read-fn read-fn-of)
 320                    (unread-index ibuf-unread-index-of)
 321                    (ef external-format-of))
 322       stream
 323     (setf unread-index (iobuf-start ib))
 324     (let* ((str nil) (ret nil)
 325            (encoding (babel:external-format-encoding ef))
 326            (max-octets-per-char
 327             (babel-encodings:enc-max-units-per-char encoding)))
 328       (flet ((fill-buf-or-eof ()
 329                (setf ret (%fill-ibuf read-fn fd ib))
 330                (when (eql :eof ret)
 331                  (return* :eof))))
 332         (cond ((zerop (iobuf-length ib))
 333                (iobuf-reset ib)
 334                (fill-buf-or-eof))
 335               ;; Some encodings such as CESU or Java's modified UTF-8 take
 336               ;; as much as 6 bytes per character. Make sure we have enough
 337               ;; space to collect read-ahead bytes if required.
 338               ((< (- (iobuf-size ib)
 339                      (iobuf-start ib))
 340                   max-octets-per-char)
 341                (iobuf-copy-data-to-start ib)
 342                (setf unread-index 0)))
 343         ;; line-end handling
 344         (when-let (it (maybe-find-line-ending read-fn fd ib ef))
 345           (return* it))
 346         (tagbody :start
 347            (handler-case
 348                (setf (values str ret)
 349                      (foreign-string-to-lisp
 350                       (iobuf-data ib)
 351                       :offset (iobuf-start ib)
 352                       :count (iobuf-length ib)
 353                       :encoding encoding
 354                       :max-chars 1))
 355              (babel:end-of-input-in-character ()
 356                (fill-buf-or-eof)
 357                (go :start)))
 358            (incf (iobuf-start ib) ret))
 359         (char str 0)))))
 360
 361 (defun maybe-find-line-ending-no-hang (fd ib ef)
 362   (declare (ignore fd))
 363   (let* ((start-off (iobuf-start ib))
 364          (char-code (bref ib start-off)))
 365     (ecase (babel:external-format-eol-style ef)
 366       (:lf (when (= char-code (char-code #\Linefeed))
 367              (incf (iobuf-start ib))
 368              (return* #\Newline)))
 369       (:cr (when (= char-code (char-code #\Return))
 370              (incf (iobuf-start ib))
 371              (return* #\Newline)))
 372       (:crlf (when (= char-code (char-code #\Return))
 373                (when (= (iobuf-length ib) 1)
 374                  (incf (iobuf-start ib))
 375                  (return* :starvation))
 376                (when (= (bref ib (1+ start-off))
 377                         (char-code #\Linefeed))
 378                  (incf (iobuf-start ib) 2)
 379                  (return* #\Newline)))))))
 380
 381 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream))
 382   (with-accessors ((fd input-fd-of)
 383                    (read-fn read-fn-of)
 384                    (ib input-buffer-of)
 385                    (ef external-format-of))
 386       stream
 387     (let* ((str nil) (ret nil) (eof nil)
 388            (encoding (babel:external-format-encoding ef))
 389            (max-octets-per-char
 390             (babel-encodings:enc-max-units-per-char encoding)))
 391       (when (< (- (iobuf-size ib)
 392                   (iobuf-start ib))
 393                max-octets-per-char)
 394         (iobuf-copy-data-to-start ib))
 395       (when (and (iomux:fd-ready-p fd :input)
 396                  (eql :eof (%fill-ibuf read-fn fd ib)))
 397         (setf eof t))
 398       (when (zerop (iobuf-length ib))
 399         (return* (if eof :eof nil)))
 400       ;; line-end handling
 401       (let ((line-end (maybe-find-line-ending-no-hang fd ib ef)))
 402         (cond ((eql :starvation line-end)
 403                (return* (if eof #\Return nil)))
 404               ((characterp line-end)
 405                (return* line-end))))
 406       ;; octet decoding
 407       (handler-case
 408           (setf (values str ret)
 409                 (foreign-string-to-lisp
 410                  (iobuf-data ib)
 411                  :offset (iobuf-start ib)
 412                  :count (iobuf-length ib)
 413                  :encoding encoding
 414                  :max-chars 1))
 415         (babel:end-of-input-in-character ()
 416           (return* nil)))
 417       (incf (iobuf-start ib) ret)
 418       (char str 0))))
 419
 420 (defun %stream-unread-char (stream)
 421   (declare (type dual-channel-gray-stream stream))
 422   (with-accessors ((ib input-buffer-of)
 423                    (unread-index ibuf-unread-index-of))
 424       stream
 425     (symbol-macrolet ((start (iobuf-start ib)))
 426       (cond
 427         ((> start unread-index) (setf start unread-index))
 428         (t (error "No uncommitted character to unread")))))
 429   nil)
 430
 431 (defmethod stream-unread-char ((stream dual-channel-gray-stream) character)
 432   (declare (ignore character))
 433   (%stream-unread-char stream))
 434
 435 (defmethod stream-peek-char ((stream dual-channel-gray-stream))
 436   (let ((char (stream-read-char stream)))
 437     (cond ((eql :eof char) :eof)
 438           (t (%stream-unread-char stream)
 439              (values char)))))
 440
 441 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
 442 ;;   )
 443
 444 (defmethod stream-listen ((stream dual-channel-gray-stream))
 445   (let ((char (stream-read-char-no-hang stream)))
 446     (cond ((characterp char) (stream-unread-char stream char) t)
 447           ((eql :eof char) nil)
 448           (t t))))
 449
 450 ;;;; Character Output
 451
 452 (defmethod stream-write-char ((stream dual-channel-gray-stream)
 453                               (character character))
 454   (flush-obuf-if-needed stream)
 455   (if (char= character #\Newline)
 456       (%write-line-terminator
 457        stream (babel:external-format-eol-style (external-format-of stream)))
 458       ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
 459       (stream-write-string stream (make-string 1 :initial-element character))))
 460
 461 (defmethod stream-line-column ((stream dual-channel-gray-stream))
 462   0)
 463
 464 (defmethod stream-start-line-p ((stream dual-channel-gray-stream))
 465   (values nil))
 466
 467 (defmethod stream-terpri ((stream dual-channel-gray-stream))
 468   (write-char #\Newline stream) nil)
 469
 470 (defmethod stream-fresh-line ((stream dual-channel-gray-stream))
 471   (write-char #\Newline stream) t)
 472
 473 (defconstant (+unix-line-terminator+ :test 'equalp)
 474   (make-array 1 :element-type 'ub8 :initial-contents '(10)))
 475
 476 (defconstant (+dos-line-terminator+ :test 'equalp)
 477   (make-array 2 :element-type 'ub8 :initial-contents '(13 10)))
 478
 479 (defconstant (+mac-line-terminator+ :test 'equalp)
 480   (make-array 1 :element-type 'ub8 :initial-contents '(13)))
 481
 482 (defun %write-line-terminator (stream line-terminator)
 483   (case line-terminator
 484     (:lf (%write-simple-array-ub8 stream +unix-line-terminator+ 0 1))
 485     (:cr (%write-simple-array-ub8 stream +mac-line-terminator+ 0 1))
 486     (:crlf (%write-simple-array-ub8 stream +dos-line-terminator+ 0 2))))
 487
 488 (defmethod stream-write-string ((stream dual-channel-gray-stream)
 489                                 (string string) &optional (start 0) end)
 490   (check-bounds string start end)
 491   (when (< start end)
 492     (let* ((octets nil)
 493            (ef (external-format-of stream))
 494            (line-terminator (babel:external-format-eol-style ef)))
 495       (loop :for off1 := start :then (1+ off2)
 496             :for nl-off := (position #\Newline string :start off1)
 497             :for off2 := (or nl-off end)
 498          :when nl-off :do (%write-line-terminator stream line-terminator)
 499          :when (> off2 off1) :do
 500          ;; FIXME: should probably convert directly to a foreign buffer?
 501          (setf octets (%to-octets string off1 off2 ef))
 502          (%write-simple-array-ub8 stream octets 0 (length octets))
 503          :while (< off2 end))))
 504   (values string))
 505
 506 ;;;; Binary Input
 507
 508 (defmethod stream-read-byte ((stream dual-channel-gray-stream))
 509   (with-accessors ((fd input-fd-of)
 510                    (read-fn read-fn-of)
 511                    (ib input-buffer-of))
 512       stream
 513     (flet ((fill-buf-or-eof ()
 514              (iobuf-reset ib)
 515              (when (eql :eof (%fill-ibuf read-fn fd ib))
 516                (return* :eof))))
 517       (when (zerop (iobuf-length ib))
 518         (fill-buf-or-eof))
 519       (iobuf-pop-octet ib))))
 520
 521 ;;;; Binary Output
 522
 523 (defmethod stream-write-byte ((stream dual-channel-gray-stream) integer)
 524   (check-type integer ub8 "an unsigned 8-bit value")
 525   (with-accessors ((ob output-buffer-of))
 526       stream
 527     (with-hangup-guard stream
 528       (flush-obuf-if-needed stream))
 529     (iobuf-push-octet ob integer)))
 530
 531 ;;;; Buffer-related stuff
 532
 533 (defmethod input-buffer-size ((stream dual-channel-gray-stream))
 534   (iobuf-length (input-buffer-of stream)))
 535
 536 (defmethod input-buffer-empty-p ((stream dual-channel-gray-stream))
 537   (iobuf-empty-p (input-buffer-of stream)))
 538
 539 (defmethod output-buffer-size ((stream dual-channel-gray-stream))
 540   (iobuf-length (output-buffer-of stream)))
 541
 542 (defmethod output-buffer-empty-p ((stream dual-channel-gray-stream))
 543   (iobuf-empty-p (output-buffer-of stream)))