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