io.streams/gray-stream-methods.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; gray-stream-methods.lisp --- Implementation using gray streams.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :io.streams)
  25
  26 ;;;; Instance Initialization
  27
  28 ;;; TODO: use the buffer pool
  29 ;;; TODO: handle instance reinitialization
  30 (defmethod shared-initialize :after ((s dual-channel-gray-stream) slot-names
  31                                      &key (input-buffer-size +bytes-per-iobuf+)
  32                                      (output-buffer-size +bytes-per-iobuf+)
  33                                      (external-format :default))
  34   (declare (ignore slot-names))
  35   (check-type input-buffer-size buffer-index)
  36   (check-type output-buffer-size buffer-index)
  37   ;; Commented this form out.  What's it for?  It doesn't allow us to
  38   ;; initialize streams with FDs as initargs, since those streams will
  39   ;; be open right away.
  40   #- (and) (when (open-stream-p s) (close s))
  41   (with-accessors ((ib input-buffer-of) (ob output-buffer-of)
  42                    (ef external-format-of)) s
  43     (setf ib (allocate-iobuf input-buffer-size)
  44           ob (allocate-iobuf output-buffer-size)
  45           ef external-format)))
  46
  47 ;;;; Common Methods
  48
  49 (defmethod stream-element-type ((stream dual-channel-gray-stream))
  50   '(unsigned-byte 8))
  51
  52 ;; TODO: use the buffer pool
  53 (defmethod close :around ((stream dual-channel-gray-stream) &key abort)
  54   (with-accessors ((ib input-buffer-of)
  55                    (ob output-buffer-of)) stream
  56     (unless (or abort (null ib)) (finish-output stream))
  57     (when ib (free-iobuf ib))
  58     (when ob (free-iobuf ob))
  59     (setf ib nil ob nil))
  60   (call-next-method)
  61   (values stream))
  62
  63 (defmethod close ((stream dual-channel-gray-stream) &key abort)
  64   (declare (ignore stream abort)))
  65
  66 (defmethod (setf external-format-of)
  67     (external-format (stream dual-channel-gray-stream))
  68   (setf (slot-value stream 'external-format)
  69         (babel:ensure-external-format external-format)))
  70
  71 ;;;; Input Methods
  72
  73 (defmethod stream-clear-input ((stream dual-channel-gray-stream))
  74   (with-accessors ((ib input-buffer-of)) stream
  75     (iobuf-reset ib)
  76     nil))
  77
  78 (defun %fill-ibuf (buf fd &optional timeout)
  79   (when timeout
  80     (let ((readablep (iomux:wait-until-fd-ready fd :read timeout)))
  81       (unless readablep
  82         (return-from %fill-ibuf :timeout))))
  83   (let ((num (nix:repeat-upon-eintr
  84                (nix:read fd (iobuf-end-pointer buf)
  85                          (iobuf-end-space-length buf)))))
  86     (if (zerop num)
  87         :eof
  88         (incf (iobuf-end buf) num))))
  89
  90 (defun %read-into-simple-array-ub8 (stream array start end)
  91   (declare (type dual-channel-gray-stream stream))
  92   (with-accessors ((ib input-buffer-of) (fd input-fd-of)) stream
  93     (let ((octets-needed (- end start)))
  94       (loop :with array-offset := start
  95             :for octets-in-buffer := (iobuf-length ib)
  96             :for nbytes := (min octets-needed octets-in-buffer)
  97          :when (plusp nbytes) :do
  98            (iobuf-copy-into-lisp-array ib (iobuf-start ib)
  99                                        array array-offset nbytes)
 100            (incf array-offset nbytes)
 101            (decf octets-needed nbytes)
 102            (incf (iobuf-start ib) nbytes)
 103          :if (zerop octets-needed) :do (loop-finish)
 104          :else :do (iobuf-reset ib)
 105          :when (eql :eof (%fill-ibuf ib fd)) :do (loop-finish)
 106          :finally (return array-offset)))))
 107
 108 (defun %read-into-string (stream string start end)
 109   (declare (type dual-channel-gray-stream stream))
 110   (loop :for offset :from start :below end
 111         :for char := (stream-read-char stream)
 112      :if (eql char :eof) :do (loop-finish)
 113      :else :do (setf (char string offset) char)
 114      :finally (return offset)))
 115
 116 (defun %read-into-vector (stream vector start end)
 117   (declare (type dual-channel-gray-stream stream))
 118   (loop :for offset :from start :below end
 119         :for octet := (stream-read-byte stream)
 120      :if (eql octet :eof) :do (loop-finish)
 121      :else :do (setf (aref vector offset) octet)
 122      :finally (return offset)))
 123
 124 (defmacro check-bounds (sequence start end)
 125   (with-gensyms (length)
 126     `(let ((,length (length ,sequence)))
 127        (unless ,end
 128          (setq ,end ,length))
 129        (unless (<= ,start ,end ,length)
 130          (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end)))))
 131
 132 (defmethod stream-read-sequence
 133     ((stream dual-channel-gray-stream) seq start end &key)
 134   (check-bounds seq start end)
 135   (when (< start end)
 136     (etypecase seq
 137       (ub8-sarray (%read-into-simple-array-ub8 stream seq start end))
 138       (string (%read-into-string stream seq start end))
 139       (ub8-vector (%read-into-vector stream seq start end)))))
 140
 141 ;;;; Output Methods
 142
 143 (defun %write-n-bytes (buf fd nbytes &optional timeout)
 144   (declare (type stream-buffer buf))
 145   (let ((bytes-written 0))
 146     (labels ((write-once ()
 147                (let ((num (handler-case
 148                               (nix:repeat-upon-condition-decreasing-timeout
 149                                   ((nix:eintr) timeout-var timeout)
 150                                 (prog1
 151                                     (nix:write
 152                                      fd (inc-pointer buf bytes-written) nbytes)
 153                                   (when (and timeout-var (zerop timeout-var))
 154                                     (return-from %write-n-bytes
 155                                       (values nil :timeout)))))
 156                             (nix:epipe ()
 157                               (return-from %write-n-bytes (values nil :eof))))))
 158                  (unless (zerop num) (incf bytes-written num))))
 159              (write-or-return ()
 160                (unless (write-once)
 161                  (when (errorp)
 162                    ;; FIXME signal something better -- maybe analyze the status
 163                    (return-from %write-n-bytes (values nil :fail)))))
 164              (buffer-emptyp () (= bytes-written nbytes))
 165              (errorp () (handler-case (iomux:wait-until-fd-ready fd :write)
 166                           (iomux:poll-error ()))))
 167       (loop :until (buffer-emptyp) :do (write-or-return)
 168          :finally (return (values t bytes-written))))))
 169
 170 (defun %flush-obuf (buf fd &optional timeout)
 171   (declare (type iobuf buf))
 172   (let ((bytes-written 0))
 173     (labels ((write-once ()
 174                (let ((num (handler-case
 175                               (nix:repeat-upon-condition-decreasing-timeout
 176                                   ((nix:eintr) timeout-var timeout)
 177                                 (prog1
 178                                     (nix:write fd (iobuf-start-pointer buf)
 179                                                (iobuf-length buf))
 180                                   (when (and timeout-var (zerop timeout-var))
 181                                     (return-from %flush-obuf
 182                                       (values nil :timeout)))))
 183                             (nix:epipe ()
 184                               (return-from %flush-obuf (values nil :eof))))))
 185                  (unless (zerop num)
 186                    (incf (iobuf-start buf) num)
 187                    (incf bytes-written num))))
 188              (write-or-return ()
 189                (unless (write-once)
 190                  (when (errorp)
 191                    ;; FIXME signal something better -- maybe analyze the status
 192                    (return-from %flush-obuf (values nil :fail)))))
 193              (buffer-emptyp ()
 194                (when (iobuf-empty-p buf)
 195                  (iobuf-reset buf) t))
 196              (errorp () (handler-case (iomux:wait-until-fd-ready fd :write)
 197                           (iomux:poll-error ()))))
 198       (loop :until (buffer-emptyp) :do (write-or-return)
 199          :finally (return (values t bytes-written))))))
 200
 201 ;;; TODO: add timeout support
 202 (defun %flush-obuf-if-needed (stream)
 203   (declare (type dual-channel-gray-stream stream))
 204   (with-accessors ((fd output-fd-of) (ob output-buffer-of)
 205                    (must-flush-output-p must-flush-output-p)) stream
 206     (when (or must-flush-output-p (iobuf-full-p ob))
 207       (%flush-obuf ob fd)
 208       (setf must-flush-output-p nil))))
 209
 210 (defmethod stream-clear-output ((stream dual-channel-gray-stream))
 211   (with-accessors ((ob output-buffer-of)
 212                    (must-flush-output-p must-flush-output-p)
 213                    (fd output-fd-of)) stream
 214     (iobuf-reset ob)
 215     (setf must-flush-output-p nil)
 216     nil))
 217
 218 (defmethod stream-finish-output ((stream dual-channel-gray-stream))
 219   (with-accessors ((ob output-buffer-of)
 220                    (must-flush-output-p must-flush-output-p)
 221                    (fd output-fd-of)) stream
 222     (%flush-obuf ob fd)
 223     (setf must-flush-output-p nil)
 224     nil))
 225
 226 (defmethod stream-force-output ((stream dual-channel-gray-stream))
 227   (setf (must-flush-output-p stream) t))
 228
 229 (defun %write-simple-array-ub8 (stream array start end)
 230   (declare (type dual-channel-gray-stream stream))
 231   (with-accessors ((ob output-buffer-of)
 232                    (fd output-fd-of)) stream
 233     (let ((octets-needed (- end start)))
 234       (cond ((<= octets-needed (iobuf-end-space-length ob))
 235              (iobuf-copy-from-lisp-array array start ob
 236                                          (iobuf-end ob) octets-needed)
 237              (incf (iobuf-end ob) octets-needed)
 238              (%flush-obuf-if-needed stream))
 239             (t
 240              (with-pointer-to-vector-data (ptr array)
 241                (%flush-obuf ob fd)
 242                (let ((ret (%write-n-bytes (inc-pointer ptr start)
 243                                           fd octets-needed)))
 244                  (when (numberp ret)
 245                    (incf (iobuf-end ob) octets-needed))))))
 246       (values array))))
 247
 248 (defun %write-vector-ub8 (stream vector start end)
 249   (declare (type dual-channel-gray-stream stream))
 250   (%write-simple-array-ub8 stream (coerce vector 'ub8-sarray) start end))
 251
 252 (defun %write-vector (stream vector start end)
 253   (declare (type dual-channel-gray-stream stream))
 254   (loop :for offset :from start :below end
 255         :for octet := (aref vector offset)
 256      :do (stream-write-byte stream octet)
 257      :finally (return vector)))
 258
 259 (defmethod stream-write-sequence ((stream dual-channel-gray-stream)
 260                                   seq start end &key)
 261   (check-bounds seq start end)
 262   (when (< start end)
 263     (etypecase seq
 264       (ub8-sarray (%write-simple-array-ub8 stream seq start end))
 265       (string (stream-write-string stream seq start end))
 266       (ub8-vector (%write-vector-ub8 stream seq start end))
 267       (vector (%write-vector stream seq start end)))))
 268
 269 ;;;; Character Input
 270
 271 (defun maybe-find-line-ending (fd ib ef)
 272   (let* ((start-off (iobuf-start ib))
 273          (char-code (bref ib start-off)))
 274     (block nil
 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 (= (iobuf-length ib) 1)
 284                             (eql (%fill-ibuf ib fd) :eof))
 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 (defconstant +max-octets-per-char+ 6)
 293
 294 ;;; FIXME: currently we return :EOF when read(2) returns 0
 295 ;;;        we should distinguish hard end-of-files (EOF and buffer empty)
 296 ;;;        from soft end-of-files (EOF and *some* bytes still in the buffer
 297 ;;;        but not enough to make a full character)
 298 (defmethod stream-read-char ((stream dual-channel-gray-stream))
 299   (with-accessors ((fd input-fd-of) (ib input-buffer-of)
 300                    (unread-index ibuf-unread-index-of)
 301                    (ef external-format-of)) stream
 302     (setf unread-index (iobuf-start ib))
 303     (let ((str nil)
 304           (ret nil))
 305       (flet ((fill-buf-or-eof ()
 306                (setf ret (%fill-ibuf ib fd))
 307                (when (eql ret :eof)
 308                  (return-from stream-read-char :eof))))
 309         (cond ((zerop (iobuf-length ib))
 310                (iobuf-reset ib)
 311                (fill-buf-or-eof))
 312               ;; Some encodings such as CESU or Java's modified UTF-8 take
 313               ;; as much as 6 bytes per character. Make sure we have enough
 314               ;; space to collect read-ahead bytes if required.
 315               ((< (iobuf-length ib) +max-octets-per-char+)
 316                (iobuf-copy-data-to-start ib)
 317                (setf unread-index 0)))
 318         ;; line-end handling
 319         (when-let ((it (maybe-find-line-ending fd ib ef)))
 320           (return-from stream-read-char it))
 321         (tagbody :start
 322            (handler-case
 323                (setf (values str ret)
 324                      (foreign-string-to-lisp
 325                       (iobuf-data ib)
 326                       :offset (iobuf-start ib)
 327                       :count (iobuf-length ib)
 328                       :encoding (babel:external-format-encoding ef)
 329                       :max-chars 1))
 330              (babel:end-of-input-in-character ()
 331                (fill-buf-or-eof)
 332                (go :start)))
 333            (incf (iobuf-start ib) ret))
 334         (char str 0)))))
 335
 336 (defun maybe-find-line-ending-no-hang (fd ib ef)
 337   (declare (ignore fd))
 338   (let* ((start-off (iobuf-start ib))
 339          (char-code (bref ib start-off)))
 340     (block nil
 341       (ecase (babel:external-format-eol-style ef)
 342         (:lf (when (= char-code (char-code #\Linefeed))
 343                (incf (iobuf-start ib))
 344                (return #\Newline)))
 345         (:cr (when (= char-code (char-code #\Return))
 346                (incf (iobuf-start ib))
 347                (return #\Newline)))
 348         (:crlf (when (= char-code (char-code #\Return))
 349                  (when (= (iobuf-length ib) 1)
 350                    (incf (iobuf-start ib))
 351                    (return :starvation))
 352                  (when (= (bref ib (1+ start-off))
 353                           (char-code #\Linefeed))
 354                    (incf (iobuf-start ib) 2)
 355                    (return #\Newline))))))))
 356
 357 (defmethod stream-read-char-no-hang ((stream dual-channel-gray-stream))
 358   (with-accessors ((fd input-fd-of) (ib input-buffer-of)
 359                    (ef external-format-of)) stream
 360     (let ((str nil)
 361           (ret nil)
 362           (eof nil))
 363       (block nil
 364         ;; BUG: this comparision is probably buggy, FIXME.  A similar
 365         ;; bug was fixed in STREAM-READ-CHAR.  Must write a test for
 366         ;; this one first.
 367         (when (< 0 (iobuf-end-space-length ib) 4)
 368           (iobuf-copy-data-to-start ib))
 369         (when (and (iomux:fd-ready-p fd :read)
 370                    (eql :eof (%fill-ibuf ib fd)))
 371           (setf eof t))
 372         (when (zerop (iobuf-length ib))
 373           (return (if eof :eof nil)))
 374         ;; line-end handling
 375         (let ((line-end (maybe-find-line-ending-no-hang fd ib ef)))
 376           (cond ((eql line-end :starvation)
 377                  (return (if eof #\Return nil)))
 378                 ((characterp line-end)
 379                  (return line-end))))
 380         ;; octet decoding
 381         (handler-case
 382             (setf (values str ret)
 383                   (foreign-string-to-lisp
 384                    (iobuf-data ib)
 385                    :offset (iobuf-start ib)
 386                    :count (iobuf-length ib)
 387                    :encoding (babel:external-format-encoding ef)
 388                    :max-chars 1))
 389           (babel:end-of-input-in-character ()
 390             (return nil)))
 391         (incf (iobuf-start ib) ret)
 392         (char str 0)))))
 393
 394 (defun %stream-unread-char (stream)
 395   (declare (type dual-channel-gray-stream stream))
 396   (with-accessors ((ib input-buffer-of)
 397                    (unread-index ibuf-unread-index-of)) stream
 398     (symbol-macrolet ((start (iobuf-start ib)))
 399       (cond
 400         ((> start unread-index) (setf start unread-index))
 401         (t (error "No uncommitted character to unread")))))
 402   nil)
 403
 404 (defmethod stream-unread-char ((stream dual-channel-gray-stream) character)
 405   (declare (ignore character))
 406   (%stream-unread-char stream))
 407
 408 (defmethod stream-peek-char ((stream dual-channel-gray-stream))
 409   (let ((char (stream-read-char stream)))
 410     (cond ((eql char :eof) :eof)
 411           (t (%stream-unread-char stream)
 412              (values char)))))
 413
 414 ;; (defmethod stream-read-line ((stream dual-channel-gray-stream))
 415 ;;   )
 416
 417 (defmethod stream-listen ((stream dual-channel-gray-stream))
 418   (let ((char (stream-read-char-no-hang stream)))
 419     (cond ((characterp char) (stream-unread-char stream char) t)
 420           ((eql char :eof) nil)
 421           (t t))))
 422
 423 ;;;; Character Output
 424
 425 (defmethod stream-write-char ((stream dual-channel-gray-stream)
 426                               (character character))
 427   (%flush-obuf-if-needed stream)
 428   (if (char= character #\Newline)
 429       (%write-line-terminator
 430        stream (babel:external-format-eol-style (external-format-of stream)))
 431       ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
 432       (stream-write-string stream (make-string 1 :initial-element character))))
 433
 434 (defmethod stream-line-column ((stream dual-channel-gray-stream))
 435   0)
 436
 437 (defmethod stream-start-line-p ((stream dual-channel-gray-stream))
 438   (values nil))
 439
 440 (defmethod stream-terpri ((stream dual-channel-gray-stream))
 441   (write-char #\Newline stream) nil)
 442
 443 (defmethod stream-fresh-line ((stream dual-channel-gray-stream))
 444   (write-char #\Newline stream) t)
 445
 446 (define-constant +unix-line-terminator+
 447     (make-array 1 :element-type 'ub8 :initial-contents '(10))
 448   :test 'equalp)
 449
 450 (define-constant +dos-line-terminator+
 451     (make-array 2 :element-type 'ub8 :initial-contents '(13 10))
 452   :test 'equalp)
 453
 454 (define-constant +mac-line-terminator+
 455     (make-array 1 :element-type 'ub8 :initial-contents '(13))
 456   :test 'equalp)
 457
 458 (defun %write-line-terminator (stream line-terminator)
 459   (case line-terminator
 460     (:lf (%write-simple-array-ub8 stream +unix-line-terminator+ 0 1))
 461     (:cr (%write-simple-array-ub8 stream +mac-line-terminator+ 0 1))
 462     (:crlf (%write-simple-array-ub8 stream +dos-line-terminator+ 0 2))))
 463
 464 (defmethod stream-write-string ((stream dual-channel-gray-stream)
 465                                 (string string) &optional (start 0) end)
 466   (check-bounds string start end)
 467   (when (< start end)
 468     (let* ((octets nil)
 469            (ef (external-format-of stream))
 470            (line-terminator (babel:external-format-eol-style ef)))
 471       (loop :for off1 := start :then (1+ off2)
 472             :for nl-off := (position #\Newline string :start off1)
 473             :for off2 := (or nl-off end)
 474          :when nl-off :do (%write-line-terminator stream line-terminator)
 475          :when (> off2 off1) :do
 476          ;; FIXME: should probably convert directly to a foreign buffer?
 477          (setf octets (babel:string-to-octets
 478                        string :start off1 :end off2
 479                        :encoding (babel:external-format-encoding ef)))
 480          (%write-simple-array-ub8 stream octets 0 (length octets))
 481          :while (< off2 end))))
 482   (values string))
 483
 484 ;;;; Binary Input
 485
 486 (defmethod stream-read-byte ((stream dual-channel-gray-stream))
 487   (with-accessors ((fd input-fd-of)
 488                    (ib input-buffer-of)) stream
 489     (flet ((fill-buf-or-eof ()
 490              (iobuf-reset ib)
 491              (when (eql :eof (%fill-ibuf ib fd))
 492                (return-from stream-read-byte :eof))))
 493       (when (zerop (iobuf-length ib))
 494         (fill-buf-or-eof))
 495       (iobuf-pop-octet ib))))
 496
 497 ;;;; Binary Output
 498
 499 (defmethod stream-write-byte ((stream dual-channel-gray-stream) integer)
 500   (check-type integer ub8 "an unsigned 8-bit value")
 501   (with-accessors ((ob output-buffer-of)) stream
 502     (%flush-obuf-if-needed stream)
 503     (iobuf-push-octet ob integer)))