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