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