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