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