src/streams/gray/io-helpers.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Low-level I/O functions.
   4 ;;;
   5
   6 (in-package :iolib.streams)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Input
  10 ;;;-------------------------------------------------------------------------
  11
  12 (declaim (inline %read-once))
  13 (defun %read-once (fd read-fn iobuf)
  14   (declare (type function read-fn)
  15            (type iobuf iobuf))
  16   (loop
  17     (handler-case
  18         (return-from %read-once
  19           (funcall read-fn fd (iobuf-end-pointer iobuf)
  20                    (iobuf-end-space-length iobuf)))
  21       (isys:ewouldblock ()
  22         (iomux:wait-until-fd-ready fd :input nil t)))))
  23
  24 (declaim (inline %fill-ibuf))
  25 (defun %fill-ibuf (iobuf fd read-fn)
  26   (declare (type iobuf iobuf))
  27   (let ((nbytes (%read-once fd read-fn iobuf)))
  28     (if (zerop nbytes)
  29         :eof
  30         (progn (incf (iobuf-end iobuf) nbytes) nbytes))))
  31
  32 (declaim (inline %read-once/no-hang))
  33 (defun %read-once/no-hang (fd read-fn iobuf)
  34   (declare (type function read-fn)
  35            (type iobuf iobuf))
  36   (handler-case
  37       (funcall read-fn fd (iobuf-end-pointer iobuf)
  38                (iobuf-end-space-length iobuf))
  39     (isys:ewouldblock () nil)))
  40
  41 (declaim (inline %fill-ibuf/no-hang))
  42 (defun %fill-ibuf/no-hang (iobuf fd read-fn)
  43   (declare (type iobuf iobuf))
  44   (let ((nbytes (%read-once/no-hang fd read-fn iobuf)))
  45     (cond
  46       ((null nbytes)
  47        0)
  48       ((plusp nbytes)
  49        (incf (iobuf-end iobuf) nbytes)
  50        nbytes)
  51       ((zerop nbytes)
  52        :eof))))
  53
  54 (defun %read-into-simple-array-ub8 (stream array start end)
  55   (declare (type dual-channel-gray-stream stream))
  56   (with-accessors ((fd fd-of)
  57                    (read-fn read-fn-of)
  58                    (iobuf input-buffer-of))
  59       stream
  60     (let ((octets-needed (- end start)))
  61       (loop :with array-offset := start
  62             :for octets-in-buffer := (iobuf-length iobuf)
  63             :for nbytes := (min octets-needed octets-in-buffer)
  64          :when (plusp nbytes) :do
  65            (iobuf-copy-into-lisp-array iobuf (iobuf-start iobuf)
  66                                        array array-offset nbytes)
  67            (incf array-offset nbytes)
  68            (decf octets-needed nbytes)
  69            (incf (iobuf-start iobuf) nbytes)
  70          :if (zerop octets-needed) :do (loop-finish)
  71          :else :do (iobuf-reset iobuf)
  72          :when (eql :eof (%fill-ibuf iobuf fd read-fn))
  73             :do (loop-finish)
  74          :finally (return array-offset)))))
  75
  76 (defun %read-into-string (stream string start end)
  77   (declare (type dual-channel-gray-stream stream))
  78   (loop :for offset :from start :below end
  79         :for char := (stream-read-char stream)
  80      :if (eql :eof char) :do (loop-finish)
  81      :else :do (setf (char string offset) char)
  82      :finally (return offset)))
  83
  84 (defun %read-into-vector (stream vector start end)
  85   (declare (type dual-channel-gray-stream stream))
  86   (loop :for offset :from start :below end
  87         :for octet := (stream-read-byte stream)
  88      :if (eql :eof octet) :do (loop-finish)
  89      :else :do (setf (aref vector offset) octet)
  90      :finally (return offset)))
  91 \f
  92
  93 ;;;-------------------------------------------------------------------------
  94 ;;; Output
  95 ;;;-------------------------------------------------------------------------
  96
  97 (defmacro with-hangup-guard (stream &body body)
  98   (with-gensyms (bytes-written hangup-p)
  99     `(multiple-value-bind (,bytes-written ,hangup-p)
 100          (progn ,@body)
 101        (declare (ignore ,bytes-written))
 102        (when (eql :hangup ,hangup-p)
 103          (error 'hangup :stream ,stream)))))
 104
 105 (defun %write-octets-from-foreign-memory (fd write-fn buf start end
 106                                           &optional non-blocking)
 107   (declare (type stream-buffer buf))
 108   (let ((old-start start))
 109     (do () ((= start end) (- start old-start))
 110       (handler-case
 111           (incf start (funcall write-fn fd (inc-pointer buf start) (- end start)))
 112         (isys:epipe ()
 113           (return (values (- start old-start) :hangup)))
 114         (isys:ewouldblock ()
 115           (if non-blocking
 116               (return (- start old-start))
 117               (iomux:wait-until-fd-ready fd :output nil t)))))))
 118
 119 (defun %write-octets-from-iobuf (write-fn fd iobuf &optional non-blocking)
 120   (declare (type iobuf iobuf))
 121   (multiple-value-bind (bytes-written hangup-p)
 122       (%write-octets-from-foreign-memory
 123        fd write-fn (iobuf-data iobuf) (iobuf-start iobuf) (iobuf-end iobuf)
 124        non-blocking)
 125     (incf (iobuf-start iobuf) bytes-written)
 126     (when (iobuf-empty-p iobuf) (iobuf-reset iobuf))
 127     (values bytes-written hangup-p)))
 128
 129 (defun %flush-obuf-if-needed (stream)
 130   (declare (type dual-channel-gray-stream stream))
 131   (with-accessors ((fd fd-of)
 132                    (write-fn write-fn-of)
 133                    (iobuf output-buffer-of)
 134                    (dirtyp dirtyp))
 135       stream
 136     (when (or dirtyp (iobuf-full-p iobuf))
 137       (multiple-value-bind (bytes-written hangup-p)
 138           (%write-octets-from-iobuf write-fn fd iobuf)
 139         (setf dirtyp nil)
 140         (return* (values bytes-written hangup-p))))
 141     0))
 142
 143 (defun %write-simple-array-ub8 (stream array start end)
 144   (declare (type dual-channel-gray-stream stream))
 145   (with-accessors ((fd fd-of)
 146                    (write-fn write-fn-of)
 147                    (iobuf output-buffer-of))
 148       stream
 149     (cond ((iobuf-can-fit-slice-p iobuf start end)
 150            (iobuf-append-slice iobuf array start end))
 151           (t
 152            (with-hangup-guard stream
 153              (%write-octets-from-iobuf write-fn fd iobuf))
 154            (with-pointer-to-vector-data (ptr array)
 155              (with-hangup-guard stream
 156                (%write-octets-from-foreign-memory fd write-fn ptr start end)))))
 157     array))
 158
 159 (defun %write-vector-ub8 (stream vector start end)
 160   (declare (type dual-channel-gray-stream stream))
 161   (%write-simple-array-ub8 stream (coerce vector 'ub8-sarray) start end))
 162
 163 (defun %write-vector (stream vector start end)
 164   (declare (type dual-channel-gray-stream stream))
 165   (loop :for offset :from start :below end
 166         :for octet := (aref vector offset)
 167      :do (stream-write-byte stream octet)
 168      :finally (return vector)))
 169 \f
 170
 171 ;;;-------------------------------------------------------------------------
 172 ;;; Character Input
 173 ;;;-------------------------------------------------------------------------
 174
 175 (defun stream-find-lf (iobuf fd read-fn)
 176   (declare (ignore fd read-fn)
 177            (type iobuf iobuf))
 178   (debug-only (assert (plusp (iobuf-length iobuf))))
 179   (cond
 180     ((= (iobuf-peek iobuf) #.(char-code #\Linefeed))
 181      (incf (iobuf-start iobuf))
 182      #\Newline)
 183     (t nil)))
 184
 185 (setf (fdefinition 'stream-find-lf/no-hang) #'stream-find-lf)
 186
 187 (defun stream-find-cr (iobuf fd read-fn)
 188   (declare (ignore fd read-fn)
 189            (type iobuf iobuf))
 190   (debug-only (assert (plusp (iobuf-length iobuf))))
 191   (cond
 192     ((= (iobuf-peek iobuf) #.(char-code #\Return))
 193      (incf (iobuf-start iobuf))
 194      #\Newline)
 195     (t nil)))
 196
 197 (setf (fdefinition 'stream-find-cr/no-hang) #'stream-find-cr)
 198
 199 (defun stream-find-crlf (iobuf fd read-fn)
 200   (declare (type iobuf iobuf))
 201   (debug-only (assert (plusp (iobuf-length iobuf))))
 202   (cond
 203     ((/= (iobuf-peek iobuf) #.(char-code #\Return))
 204      nil)
 205     ((and (= 1 (iobuf-length iobuf))
 206           (eql :eof (%fill-ibuf iobuf fd read-fn)))
 207      nil)
 208     ((= (iobuf-peek iobuf 1) #.(char-code #\Linefeed))
 209      (incf (iobuf-start iobuf) 2)
 210      #\Newline)
 211     (t nil)))
 212
 213 (defun stream-find-crlf/no-hang (iobuf fd read-fn)
 214   (declare (type iobuf iobuf))
 215   (debug-only (assert (plusp (iobuf-length iobuf))))
 216   (cond
 217     ((/= (iobuf-peek iobuf) #.(char-code #\Return))
 218      nil)
 219     ((= 1 (iobuf-length iobuf))
 220      (if (eql :eof (%fill-ibuf/no-hang iobuf fd read-fn))
 221          nil
 222          :incomplete))
 223     ((= (iobuf-peek iobuf 1) #.(char-code #\Linefeed))
 224      (incf (iobuf-start iobuf) 2)
 225      #\Newline)
 226     (t nil)))
 227
 228 (defun maybe-rewind-iobuf (iobuf encoding)
 229   (let ((max-octets-per-char
 230          (babel-encodings:enc-max-units-per-char encoding)))
 231     ;; Some encodings such as CESU or Java's modified UTF-8 take
 232     ;; as much as 6 bytes per character. Make sure we have enough
 233     ;; space to collect read-ahead bytes if required.
 234     (when (< (- (iobuf-size iobuf)
 235                 (iobuf-start iobuf))
 236              max-octets-per-char)
 237       (iobuf-copy-data-to-start iobuf))))
 238
 239 (defun decode-one-char (fd read-fn iobuf encoding)
 240   (debug-only (assert (plusp (iobuf-length iobuf))))
 241   (loop
 242      (handler-case
 243          (multiple-value-bind (str ret)
 244              (foreign-string-to-lisp (iobuf-data iobuf)
 245                                      :offset (iobuf-start iobuf)
 246                                      :count (iobuf-length iobuf)
 247                                      :encoding encoding
 248                                      :max-chars 1)
 249            (incf (iobuf-start iobuf) ret)
 250            (return* (char str 0)))
 251        (babel:end-of-input-in-character ()
 252          (let ((nbytes (%fill-ibuf iobuf fd read-fn)))
 253            ;; Even if the buffer contains octets representing an
 254            ;; incomplete character, we return EOF because the Gray
 255            ;; streams API doesn't distinguish between "no data" and
 256            ;; "partial data"
 257            (when (eql :eof nbytes)
 258              (return* :eof)))))))
 259
 260 (defun decode-one-char/no-hang (iobuf encoding)
 261   (debug-only (assert (plusp (iobuf-length iobuf))))
 262   (handler-case
 263       (multiple-value-bind (string ret)
 264           (foreign-string-to-lisp (iobuf-data iobuf)
 265                                   :offset (iobuf-start iobuf)
 266                                   :count (iobuf-length iobuf)
 267                                   :encoding encoding
 268                                   :max-chars 1)
 269         (incf (iobuf-start iobuf) ret)
 270         (char string 0))
 271     (babel:end-of-input-in-character () nil)))
 272 \f
 273
 274 ;;;-------------------------------------------------------------------------
 275 ;;; Character Output
 276 ;;;-------------------------------------------------------------------------
 277
 278 (defun stream-write-lf (stream)
 279   (declare (type dual-channel-gray-stream stream))
 280   (let ((octets #.(map 'ub8-sarray #'char-code '(#\Linefeed))))
 281     (%write-simple-array-ub8 stream octets 0 1)))
 282
 283 (defun stream-write-crlf (stream)
 284   (declare (type dual-channel-gray-stream stream))
 285   (let ((octets #.(map 'ub8-sarray #'char-code '(#\Return #\Linefeed))))
 286     (%write-simple-array-ub8 stream octets 0 2)))
 287
 288 (defun stream-write-cr (stream)
 289   (declare (type dual-channel-gray-stream stream))
 290   (let ((octets #.(map 'ub8-sarray #'char-code '(#\Return))))
 291     (%write-simple-array-ub8 stream octets 0 1)))
 292
 293 (declaim (inline %write-string-chunk))
 294 (defun %write-string-chunk (stream string start end encoding)
 295   (let* ((chunk-end
 296           (or (position #\Newline string :start start :end end) end))
 297          (octets
 298           (babel:string-to-octets string
 299                                   :start start :end chunk-end
 300                                   :encoding encoding)))
 301     (%write-simple-array-ub8 stream octets 0 (length octets))
 302     chunk-end))