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