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