io.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 :io.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 &optional timeout)
  72   (when timeout
  73     (let ((readablep (iomux:wait-until-fd-ready fd :input timeout)))
  74       (unless readablep
  75         (return* :timeout))))
  76   (let ((num (nix:repeat-upon-eintr
  77                (funcall read-fn fd (iobuf-end-pointer buf)
  78                         (iobuf-end-space-length buf)))))
  79     (if (zerop num)
  80         :eof
  81         (incf (iobuf-end buf) num))))
  82
  83 (defun %read-into-simple-array-ub8 (stream array start end)
  84   (declare (type dual-channel-gray-stream stream))
  85   (with-accessors ((ib input-buffer-of)
  86                    (fd input-fd-of)
  87                    (read-fn read-fn-of))
  88       stream
  89     (let ((octets-needed (- end start)))
  90       (loop :with array-offset := start
  91             :for octets-in-buffer := (iobuf-length ib)
  92             :for nbytes := (min octets-needed octets-in-buffer)
  93          :when (plusp nbytes) :do
  94            (iobuf-copy-into-lisp-array ib (iobuf-start ib)
  95                                        array array-offset nbytes)
  96            (incf array-offset nbytes)
  97            (decf octets-needed nbytes)
  98            (incf (iobuf-start ib) nbytes)
  99          :if (zerop octets-needed) :do (loop-finish)
 100          :else :do (iobuf-reset ib)
 101          :when (eq :eof (%fill-ibuf read-fn fd ib)) :do (loop-finish)
 102          :finally (return array-offset)))))
 103
 104 (defun %read-into-string (stream string start end)
 105   (declare (type dual-channel-gray-stream stream))
 106   (loop :for offset :from start :below end
 107         :for char := (stream-read-char stream)
 108      :if (eq char :eof) :do (loop-finish)
 109      :else :do (setf (char string offset) char)
 110      :finally (return offset)))
 111
 112 (defun %read-into-vector (stream vector start end)
 113   (declare (type dual-channel-gray-stream stream))
 114   (loop :for offset :from start :below end
 115         :for octet := (stream-read-byte stream)
 116      :if (eq octet :eof) :do (loop-finish)
 117      :else :do (setf (aref vector offset) octet)
 118      :finally (return offset)))
 119
 120 (defmacro check-bounds (sequence start end)
 121   (with-gensyms (length)
 122     `(let ((,length (length ,sequence)))
 123        (unless ,end
 124          (setq ,end ,length))
 125        (unless (<= ,start ,end ,length)
 126          (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end)))))
 127
 128 (declaim (inline %read-sequence))
 129 (defun %read-sequence (stream seq start end)
 130   (check-bounds seq start end)
 131   (when (< start end)
 132     (etypecase seq
 133       (ub8-sarray (%read-into-simple-array-ub8 stream seq start end))
 134       (string (%read-into-string stream seq start end))
 135       (ub8-vector (%read-into-vector stream seq start end)))))
 136
 137 (declaim (inline read-sequence*))
 138 (defun read-sequence* (stream sequence &key (start 0) end)
 139   (%read-sequence stream sequence start end))
 140
 141 (defmethod stream-read-sequence
 142     ((stream dual-channel-gray-stream) sequence start end &key)
 143   (%read-sequence stream sequence start end))
 144
 145 (defmethod drain-input-buffer
 146     ((stream dual-channel-gray-stream) sequence &key (start 0) end)
 147   (check-bounds sequence start end)
 148   (with-accessors ((ib input-buffer-of))
 149       stream
 150     (let ((nbytes (min (- end start)
 151                        (iobuf-length ib))))
 152       (when (plusp nbytes)
 153         (iobuf-copy-into-lisp-array ib (iobuf-start ib)
 154                                     sequence start
 155                                     nbytes)
 156         (incf (iobuf-start ib) nbytes)
 157         (let ((len (iobuf-length ib)))
 158           (values (+ start nbytes)
 159                   (and (plusp len) len)))))))
 160
 161 ;;;; Output Methods
 162
 163 (defun %write-n-bytes (write-fn fd buf nbytes &optional timeout)
 164   (declare (type stream-buffer buf))
 165   (let ((bytes-written 0))
 166     (labels ((write-once ()
 167                (let ((num (handler-case
 168                               (nix:repeat-upon-condition-decreasing-timeout
 169                                   ((nix:eintr) timeout-var timeout)
 170                                 (prog1
 171                                     (funcall write-fn fd (inc-pointer buf bytes-written)
 172                                              nbytes)
 173                                   (when (and timeout-var (zerop timeout-var))
 174                                     (return* (values nil :timeout)))))
 175                             (nix:epipe ()
 176                               (return* (values nil :eof))))))
 177                  (unless (zerop num) (incf bytes-written num))))
 178              (write-or-return ()
 179                (unless (write-once)
 180                  (when (errorp)
 181                    ;; FIXME signal something better -- maybe analyze the status
 182                    (return* (values nil :fail)))))
 183              (buffer-emptyp () (= bytes-written nbytes))
 184              (errorp () (handler-case (iomux:wait-until-fd-ready fd :output)
 185                           (iomux:poll-error () t)
 186                           (:no-error (r w) (declare (ignore r w)) nil))))
 187       (loop :until (buffer-emptyp) :do (write-or-return)
 188          :finally (return (values t bytes-written))))))
 189
 190 (defun %flush-obuf (write-fn fd buf &optional timeout)
 191   (declare (type iobuf buf))
 192   (let ((bytes-written 0))
 193     (labels ((write-once ()
 194                (let ((num (handler-case
 195                               (nix:repeat-upon-condition-decreasing-timeout
 196                                   ((nix:eintr) timeout-var timeout)
 197                                 (prog1
 198                                     (funcall write-fn fd (iobuf-start-pointer buf)
 199                                              (iobuf-length buf))
 200                                   (when (and timeout-var (zerop timeout-var))
 201                                     (return* (values nil :timeout)))))
 202                             (nix:epipe ()
 203                               (return* (values nil :eof))))))
 204                  (unless (zerop num)
 205                    (incf (iobuf-start buf) num)
 206                    (incf bytes-written num))))
 207              (write-or-return ()
 208                (unless (write-once)
 209                  (when (errorp)
 210                    ;; FIXME signal something better -- maybe analyze the status
 211                    (return* (values nil :fail)))))
 212              (buffer-emptyp ()
 213                (when (iobuf-empty-p buf)
 214                  (iobuf-reset buf) t))
 215              (errorp () (handler-case (iomux:wait-until-fd-ready fd :output)
 216                           (iomux:poll-error () t)
 217                           (:no-error (r w) (declare (ignore r w)) nil))))
 218       (loop :until (buffer-emptyp) :do (write-or-return)
 219          :finally (return (values t bytes-written))))))
 220
 221 ;;; TODO: add timeout support
 222 (defun %flush-obuf-if-needed (stream)
 223   (declare (type dual-channel-gray-stream stream))
 224   (with-accessors ((fd output-fd-of)
 225                    (write-fn write-fn-of)
 226                    (ob output-buffer-of)
 227                    (dirtyp dirtyp))
 228       stream
 229     (when (or dirtyp (iobuf-full-p ob))
 230       (%flush-obuf write-fn fd ob)
 231       (setf dirtyp nil))))
 232
 233 (defmethod stream-clear-output ((stream dual-channel-gray-stream))
 234   (with-accessors ((ob output-buffer-of)
 235                    (dirtyp dirtyp))
 236       stream
 237     (iobuf-reset ob)
 238     (setf dirtyp nil)
 239     nil))
 240
 241 (defmethod stream-finish-output ((stream dual-channel-gray-stream))
 242   (with-accessors ((fd output-fd-of)
 243                    (write-fn write-fn-of)
 244                    (ob output-buffer-of)
 245                    (dirtyp dirtyp))
 246       stream
 247     (%flush-obuf write-fn fd ob)
 248     (setf dirtyp nil)
 249     nil))
 250
 251 (defmethod stream-force-output ((stream dual-channel-gray-stream))
 252   (setf (dirtyp stream) t))
 253
 254 (defun %write-simple-array-ub8 (stream array start end)
 255   (declare (type dual-channel-gray-stream stream))
 256   (with-accessors ((fd output-fd-of)
 257                    (write-fn write-fn-of)
 258                    (ob output-buffer-of))
 259       stream
 260     (let ((octets-needed (- end start)))
 261       (cond ((<= octets-needed (iobuf-end-space-length ob))
 262              (iobuf-copy-from-lisp-array array start ob
 263                                          (iobuf-end ob) octets-needed)
 264              (incf (iobuf-end ob) octets-needed)
 265              (%flush-obuf-if-needed stream))
 266             (t
 267              (with-pointer-to-vector-data (ptr array)
 268                (%flush-obuf write-fn fd ob)
 269                (%write-n-bytes write-fn fd (inc-pointer ptr start) octets-needed))))
 270       (values array))))
 271
 272 (defun %write-vector-ub8 (stream vector start end)
 273   (declare (type dual-channel-gray-stream stream))
 274   (%write-simple-array-ub8 stream (coerce vector 'ub8-sarray) start end))
 275
 276 (defun %write-vector (stream vector start end)
 277   (declare (type dual-channel-gray-stream stream))
 278   (loop :for offset :from start :below end
 279         :for octet := (aref vector offset)
 280      :do (stream-write-byte stream octet)
 281      :finally (return vector)))
 282
 283 (declaim (inline %write-sequence))
 284 (defun %write-sequence (stream seq start end)
 285   (check-bounds seq start end)
 286   (when (< start end)
 287     (etypecase seq
 288       (ub8-sarray (%write-simple-array-ub8 stream seq start end))
 289       (string (stream-write-string stream seq start end))
 290       (ub8-vector (%write-vector-ub8 stream seq start end))
 291       (vector (%write-vector stream seq start end)))))
 292
 293 (declaim (inline write-sequence*))
 294 (defun write-sequence* (stream sequence &key (start 0) end)
 295   (%write-sequence stream sequence start end))
 296
 297 (defmethod stream-write-sequence ((stream dual-channel-gray-stream)
 298                                   sequence start end &key)
 299   (%write-sequence stream sequence start end))
 300
 301 ;;;; Character Input
 302
 303 (defun maybe-find-line-ending (read-fn fd ib ef)
 304   (let* ((start-off (iobuf-start ib))
 305          (char-code (bref ib start-off)))
 306     (block nil
 307       (ecase (babel:external-format-eol-style ef)
 308         (:lf (when (= char-code (char-code #\Linefeed))
 309                (incf (iobuf-start ib))
 310                (return #\Newline)))
 311         (:cr (when (= char-code (char-code #\Return))
 312                (incf (iobuf-start ib))
 313                (return #\Newline)))
 314         (:crlf (when (= char-code (char-code #\Return))
 315                  (when (and (= (iobuf-length ib) 1)
 316                             (eq :eof (%fill-ibuf read-fn fd ib)))
 317                    (incf (iobuf-start ib))
 318                    (return #\Return))
 319                  (when (= (bref ib (1+ start-off))
 320                           (char-code #\Linefeed))
 321                    (incf (iobuf-start ib) 2)
 322                    (return #\Newline))))))))
 323
 324 (defconstant +max-octets-per-char+ 6)
 325
 326 ;;; FIXME: currently we return :EOF when read(2) returns 0
 327 ;;;        we should distinguish hard end-of-files (EOF and buffer empty)
 328 ;;;        from soft end-of-files (EOF and *some* bytes still in the buffer
 329 ;;;        but not enough to make a full character)
 330 (defmethod stream-read-char ((stream dual-channel-gray-stream))
 331   (with-accessors ((fd input-fd-of)
 332                    (ib input-buffer-of)
 333                    (read-fn read-fn-of)
 334                    (unread-index ibuf-unread-index-of)
 335                    (ef external-format-of))
 336       stream
 337     (setf unread-index (iobuf-start ib))
 338     (let ((str nil)
 339           (ret nil))
 340       (flet ((fill-buf-or-eof ()
 341                (setf ret (%fill-ibuf read-fn fd ib))
 342                (when (eq ret :eof)
 343                  (return* :eof))))
 344         (cond ((zerop (iobuf-length ib))
 345                (iobuf-reset ib)
 346                (fill-buf-or-eof))
 347               ;; Some encodings such as CESU or Java's modified UTF-8 take
 348               ;; as much as 6 bytes per character. Make sure we have enough
 349               ;; space to collect read-ahead bytes if required.
 350               ((< (iobuf-length ib) +max-octets-per-char+)
 351                (iobuf-copy-data-to-start ib)
 352                (setf unread-index 0)))
 353         ;; line-end handling
 354         (when-let (it (maybe-find-line-ending read-fn fd ib ef))
 355           (return* it))
 356         (tagbody :start
 357            (handler-case
 358                (setf (values str ret)
 359                      (foreign-string-to-lisp
 360                       (iobuf-data ib)
 361                       :offset (iobuf-start ib)
 362                       :count (iobuf-length ib)
 363                       :encoding (babel:external-format-encoding ef)
 364                       :max-chars 1))
 365              (babel:end-of-input-in-character ()
 366                (fill-buf-or-eof)
 367                (go :start)))
 368            (incf (iobuf-start ib) ret))
 369         (char str 0)))))
 370
 371 (defun maybe-find-line-ending-no-hang (fd ib ef)
 372   (declare (ignore fd))
 373   (let* ((start-off (iobuf-start ib))
 374          (char-code (bref ib start-off)))
 375     (block nil
 376       (ecase (babel:external-format-eol-style ef)
 377         (:lf (when (= char-code (char-code #\Linefeed))
 378                (incf (iobuf-start ib))
 379                (return #\Newline)))
 380         (:cr (when (= char-code (char-code #\Return))
 381                (incf (iobuf-start ib))
 382                (return #\Newline)))
 383         (:crlf (when (= char-code (char-code #\Return))
 384                  (when (= (iobuf-length ib) 1)
 385                    (incf (iobuf-start ib))
 386                    (return :starvation))
 387                  (when (= (bref ib (1+ start-off))
 388                           (char-code #\Linefeed))
 389                    (incf (iobuf-start ib) 2)
 390                    (return #\Newline))))))))
 391
 392 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream))
 393   (with-accessors ((fd input-fd-of)
 394                    (read-fn read-fn-of)
 395                    (ib input-buffer-of)
 396                    (ef external-format-of))
 397       stream
 398     (let ((str nil)
 399           (ret nil)
 400           (eof nil))
 401       (block nil
 402         ;; BUG: this comparision is probably buggy, FIXME.  A similar
 403         ;; bug was fixed in STREAM-READ-CHAR.  Must write a test for
 404         ;; this one first.
 405         (when (< 0 (iobuf-end-space-length ib) 4)
 406           (iobuf-copy-data-to-start ib))
 407         (when (and (iomux:fd-ready-p fd :input)
 408                    (eq :eof (%fill-ibuf read-fn fd ib)))
 409           (setf eof t))
 410         (when (zerop (iobuf-length ib))
 411           (return (if eof :eof nil)))
 412         ;; line-end handling
 413         (let ((line-end (maybe-find-line-ending-no-hang fd ib ef)))
 414           (cond ((eq line-end :starvation)
 415                  (return (if eof #\Return nil)))
 416                 ((characterp line-end)
 417                  (return line-end))))
 418         ;; octet decoding
 419         (handler-case
 420             (setf (values str ret)
 421                   (foreign-string-to-lisp
 422                    (iobuf-data ib)
 423                    :offset (iobuf-start ib)
 424                    :count (iobuf-length ib)
 425                    :encoding (babel:external-format-encoding ef)
 426                    :max-chars 1))
 427           (babel:end-of-input-in-character ()
 428             (return nil)))
 429         (incf (iobuf-start ib) ret)
 430         (char str 0)))))
 431
 432 (defun %stream-unread-char (stream)
 433   (declare (type dual-channel-gray-stream stream))
 434   (with-accessors ((ib input-buffer-of)
 435                    (unread-index ibuf-unread-index-of))
 436       stream
 437     (symbol-macrolet ((start (iobuf-start ib)))
 438       (cond
 439         ((> start unread-index) (setf start unread-index))
 440         (t (error "No uncommitted character to unread")))))
 441   nil)
 442
 443 (defmethod stream-unread-char ((stream dual-channel-gray-stream) character)
 444   (declare (ignore character))
 445   (%stream-unread-char stream))
 446
 447 (defmethod stream-peek-char ((stream dual-channel-gray-stream))
 448   (let ((char (stream-read-char stream)))
 449     (cond ((eq char :eof) :eof)
 450           (t (%stream-unread-char stream)
 451              (values char)))))
 452
 453 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
 454 ;;   )
 455
 456 (defmethod stream-listen ((stream dual-channel-gray-stream))
 457   (let ((char (stream-read-char-no-hang stream)))
 458     (cond ((characterp char) (stream-unread-char stream char) t)
 459           ((eq char :eof) nil)
 460           (t t))))
 461
 462 ;;;; Character Output
 463
 464 (defmethod stream-write-char ((stream dual-channel-gray-stream)
 465                               (character character))
 466   (%flush-obuf-if-needed stream)
 467   (if (char= character #\Newline)
 468       (%write-line-terminator
 469        stream (babel:external-format-eol-style (external-format-of stream)))
 470       ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
 471       (stream-write-string stream (make-string 1 :initial-element character))))
 472
 473 (defmethod stream-line-column ((stream dual-channel-gray-stream))
 474   0)
 475
 476 (defmethod stream-start-line-p ((stream dual-channel-gray-stream))
 477   (values nil))
 478
 479 (defmethod stream-terpri ((stream dual-channel-gray-stream))
 480   (write-char #\Newline stream) nil)
 481
 482 (defmethod stream-fresh-line ((stream dual-channel-gray-stream))
 483   (write-char #\Newline stream) t)
 484
 485 (define-constant +unix-line-terminator+
 486     (make-array 1 :element-type 'ub8 :initial-contents '(10))
 487   :test 'equalp)
 488
 489 (define-constant +dos-line-terminator+
 490     (make-array 2 :element-type 'ub8 :initial-contents '(13 10))
 491   :test 'equalp)
 492
 493 (define-constant +mac-line-terminator+
 494     (make-array 1 :element-type 'ub8 :initial-contents '(13))
 495   :test 'equalp)
 496
 497 (defun %write-line-terminator (stream line-terminator)
 498   (case line-terminator
 499     (:lf (%write-simple-array-ub8 stream +unix-line-terminator+ 0 1))
 500     (:cr (%write-simple-array-ub8 stream +mac-line-terminator+ 0 1))
 501     (:crlf (%write-simple-array-ub8 stream +dos-line-terminator+ 0 2))))
 502
 503 (defmethod stream-write-string ((stream dual-channel-gray-stream)
 504                                 (string string) &optional (start 0) end)
 505   (check-bounds string start end)
 506   (when (< start end)
 507     (let* ((octets nil)
 508            (ef (external-format-of stream))
 509            (line-terminator (babel:external-format-eol-style ef)))
 510       (loop :for off1 := start :then (1+ off2)
 511             :for nl-off := (position #\Newline string :start off1)
 512             :for off2 := (or nl-off end)
 513          :when nl-off :do (%write-line-terminator stream line-terminator)
 514          :when (> off2 off1) :do
 515          ;; FIXME: should probably convert directly to a foreign buffer?
 516          (setf octets (%to-octets string off1 off2 ef))
 517          (%write-simple-array-ub8 stream octets 0 (length octets))
 518          :while (< off2 end))))
 519   (values string))
 520
 521 ;;;; Binary Input
 522
 523 (defmethod stream-read-byte ((stream dual-channel-gray-stream))
 524   (with-accessors ((fd input-fd-of)
 525                    (read-fn read-fn-of)
 526                    (ib input-buffer-of))
 527       stream
 528     (flet ((fill-buf-or-eof ()
 529              (iobuf-reset ib)
 530              (when (eq :eof (%fill-ibuf read-fn fd ib))
 531                (return* :eof))))
 532       (when (zerop (iobuf-length ib))
 533         (fill-buf-or-eof))
 534       (iobuf-pop-octet ib))))
 535
 536 ;;;; Binary Output
 537
 538 (defmethod stream-write-byte ((stream dual-channel-gray-stream) integer)
 539   (check-type integer ub8 "an unsigned 8-bit value")
 540   (with-accessors ((ob output-buffer-of))
 541       stream
 542     (%flush-obuf-if-needed stream)
 543     (iobuf-push-octet ob integer)))
 544
 545 ;;;; Buffer-related stuff
 546
 547 (defmethod input-buffer-size ((stream dual-channel-gray-stream))
 548   (iobuf-length (input-buffer-of stream)))
 549
 550 (defmethod input-buffer-empty-p ((stream dual-channel-gray-stream))
 551   (iobuf-empty-p (input-buffer-of stream)))
 552
 553 (defmethod output-buffer-size ((stream dual-channel-gray-stream))
 554   (iobuf-length (output-buffer-of stream)))
 555
 556 (defmethod output-buffer-empty-p ((stream dual-channel-gray-stream))
 557   (iobuf-empty-p (output-buffer-of stream)))