Commit de26a27d authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

Working input-replacement restart for decoding errors

It's all mildly horrible.  The input buffer-handling code is in
streams.lisp, notionally generic code, which means that it's very hard
to communicate out-of-band reasons for filling 0 characters (which could
happen on end-of-file, on forced-end-of-file, on resync and now on
input-replacement).  Instead, we have to communicate that out-of-band
information between different fd-streams functions using extra slots in
the stream, which is all fragile and intertwingly.

One thing that has changed is that we're no longer using an UNREAD slot
for dealing with unread-char; instead we always alter the buffer
pointers.  We don't get that slot back, though; instead we use it for
stuff to read in preference to the input buffer, FD-STREAM-INSTEAD.
Most of the work in this patch is making sure that this is in fact
always read first when necessary.

This rearrangement also fixes the double-decoding-error when using the
force-end-of-file restart, by using yet another new slot for noting that
EOF was forced, so test for that in the relevant regression test (by
counting the number of times the handler function is called).
parent f0ba533e
......@@ -171,8 +171,9 @@
(listen nil :type (member nil t :eof))
;; the input buffer
(unread nil)
(instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*)))
(ibuf nil :type (or buffer null))
(eof-forced-p nil :type (member t nil))
;; the output buffer
(obuf nil :type (or buffer null))
......@@ -462,7 +463,24 @@
(force-end-of-file ()
:report (lambda (stream)
(format stream "~@<Force an end of file.~@:>"))
t)))
(setf (fd-stream-eof-forced-p stream) t))
(input-replacement (string)
:report (lambda (stream)
(format stream "~@<Use string as replacement input, ~
attempt to resync at a character ~
boundary and continue.~@:>"))
:interactive (lambda ()
(format *query-io* "~@<Enter a string: ~@:>")
(finish-output *query-io*)
(list (read *query-io*)))
(let ((string (reverse (string string)))
(instead (fd-stream-instead stream)))
(dotimes (i (length string))
(vector-push-extend (char string i) instead))
(fd-stream-resync stream)
(when (> (length string) 0)
(setf (fd-stream-listen stream) t)))
nil)))
(defun stream-encoding-error-and-handle (stream code)
(restart-case
......@@ -966,47 +984,54 @@
`(let* ((,stream-var ,stream)
(ibuf (fd-stream-ibuf ,stream-var))
(size nil))
(if (fd-stream-unread ,stream-var)
(prog1
(fd-stream-unread ,stream-var)
(setf (fd-stream-unread ,stream-var) nil)
(setf (fd-stream-listen ,stream-var) nil))
(let ((,element-var nil)
(decode-break-reason nil))
(do ((,retry-var t))
((not ,retry-var))
(unless
(catch 'eof-input-catcher
(setf decode-break-reason
(block decode-break-reason
(input-at-least ,stream-var 1)
(let* ((byte (sap-ref-8 (buffer-sap ibuf)
(buffer-head ibuf))))
(declare (ignorable byte))
(setq size ,bytes)
(input-at-least ,stream-var size)
(setq ,element-var (locally ,@read-forms))
(setq ,retry-var nil))
nil))
(when decode-break-reason
(when (stream-decoding-error-and-handle
stream decode-break-reason)
(setq ,retry-var nil)
(throw 'eof-input-catcher nil)))
t)
(let ((octet-count (- (buffer-tail ibuf)
(buffer-head ibuf))))
(when (or (zerop octet-count)
(and (not ,element-var)
(not decode-break-reason)
(stream-decoding-error-and-handle
stream octet-count)))
(setq ,retry-var nil)))))
(cond (,element-var
(incf (buffer-head ibuf) size)
,element-var)
(t
(eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
(block use-instead
(when (fd-stream-eof-forced-p ,stream-var)
(setf (fd-stream-eof-forced-p ,stream-var) nil)
(return-from use-instead
(eof-or-lose ,stream-var ,eof-error ,eof-value)))
(let ((,element-var nil)
(decode-break-reason nil))
(do ((,retry-var t))
((not ,retry-var))
(if (> (length (fd-stream-instead ,stream-var)) 0)
(let* ((instead (fd-stream-instead ,stream-var))
(result (vector-pop instead))
(pointer (fill-pointer instead)))
(when (= pointer 0)
(setf (fd-stream-listen ,stream-var) nil))
(return-from use-instead result))
(unless
(catch 'eof-input-catcher
(setf decode-break-reason
(block decode-break-reason
(input-at-least ,stream-var 1)
(let* ((byte (sap-ref-8 (buffer-sap ibuf)
(buffer-head ibuf))))
(declare (ignorable byte))
(setq size ,bytes)
(input-at-least ,stream-var size)
(setq ,element-var (locally ,@read-forms))
(setq ,retry-var nil))
nil))
(when decode-break-reason
(when (stream-decoding-error-and-handle
stream decode-break-reason)
(setq ,retry-var nil)
(throw 'eof-input-catcher nil)))
t)
(let ((octet-count (- (buffer-tail ibuf)
(buffer-head ibuf))))
(when (or (zerop octet-count)
(and (not ,element-var)
(not decode-break-reason)
(stream-decoding-error-and-handle
stream octet-count)))
(setq ,retry-var nil))))))
(cond (,element-var
(incf (buffer-head ibuf) size)
,element-var)
(t
(eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
;;; a macro to wrap around all input routines to handle EOF-ERROR noise
(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
......@@ -1014,11 +1039,8 @@
(element-var (gensym "ELT")))
`(let* ((,stream-var ,stream)
(ibuf (fd-stream-ibuf ,stream-var)))
(if (fd-stream-unread ,stream-var)
(prog1
(fd-stream-unread ,stream-var)
(setf (fd-stream-unread ,stream-var) nil)
(setf (fd-stream-listen ,stream-var) nil))
(if (> (length (fd-stream-instead ,stream-var)) 0)
(bug "INSTEAD not empty in INPUT-WRAPPER for ~S" ,stream-var)
(let ((,element-var
(catch 'eof-input-catcher
(input-at-least ,stream-var ,bytes)
......@@ -1167,22 +1189,7 @@
&aux (total-copied 0))
(declare (type fd-stream stream))
(declare (type index start requested total-copied))
(let ((unread (fd-stream-unread stream)))
(when unread
;; AVERs designed to fail when we have more complicated
;; character representations.
(aver (typep unread 'base-char))
(aver (= (fd-stream-element-size stream) 1))
;; KLUDGE: this is a slightly-unrolled-and-inlined version of
;; %BYTE-BLT
(etypecase buffer
(system-area-pointer
(setf (sap-ref-8 buffer start) (char-code unread)))
((simple-unboxed-array (*))
(setf (aref buffer start) unread)))
(setf (fd-stream-unread stream) nil)
(setf (fd-stream-listen stream) nil)
(incf total-copied)))
(aver (= (length (fd-stream-instead stream)) 0))
(do ()
(nil)
(let* ((remaining-request (- requested total-copied))
......@@ -1323,12 +1330,16 @@
(type
(simple-array character (#.+ansi-stream-in-buffer-length+))
buffer))
(let ((unread (fd-stream-unread stream)))
(when unread
(setf (aref buffer index) unread)
(setf (fd-stream-unread stream) nil)
(setf (fd-stream-listen stream) nil)
(incf index)))
(when (fd-stream-eof-forced-p stream)
(setf (fd-stream-eof-forced-p stream) nil)
(return-from ,in-function 0))
(do ((instead (fd-stream-instead stream)))
((= (fill-pointer instead) 0)
(setf (fd-stream-listen stream) nil))
(setf (aref buffer index) (vector-pop instead))
(incf index)
(when (= index end)
(return-from ,in-function (- index start))))
(do ()
(nil)
(let* ((ibuf (fd-stream-ibuf stream))
......@@ -1498,12 +1509,16 @@
(type
(simple-array character (#.+ansi-stream-in-buffer-length+))
buffer))
(let ((unread (fd-stream-unread stream)))
(when unread
(setf (aref buffer start) unread)
(setf (fd-stream-unread stream) nil)
(setf (fd-stream-listen stream) nil)
(incf total-copied)))
(when (fd-stream-eof-forced-p stream)
(setf (fd-stream-eof-forced-p stream) nil)
(return-from ,in-function 0))
(do ((instead (fd-stream-instead stream)))
((= (fill-pointer instead) 0)
(setf (fd-stream-listen stream) nil))
(setf (aref buffer (+ start total-copied)) (vector-pop instead))
(incf total-copied)
(when (= requested total-copied)
(return-from ,in-function total-copied)))
(do ()
(nil)
(let* ((ibuf (fd-stream-ibuf stream))
......@@ -1541,8 +1556,10 @@
(if eof-error-p
(error 'end-of-file :stream stream)
(return-from ,in-function total-copied)))
(setf head (buffer-head ibuf))
(setf tail (buffer-tail ibuf))))
;; we might have been given stuff to use instead, so
;; we have to return (and trust our caller to know
;; what to do about TOTAL-COPIED being 0).
(return-from ,in-function total-copied)))
(setf (buffer-head ibuf) head)
;; Maybe we need to refill the stream buffer.
(cond ( ;; If there were enough data in the stream buffer, we're done.
......@@ -1579,7 +1596,7 @@
(input-at-least stream size)
(setf head (buffer-head ibuf))
,in-expr)
nil)
nil)
(return)))))
(defun ,read-c-string-function (sap element-type)
(declare (type system-area-pointer sap))
......@@ -1963,13 +1980,12 @@
;; we're still safe: buffers have finalizers of their own.
(release-fd-stream-buffers fd-stream))
;;; Flushes the current input buffer and unread chatacter, and returns
;;; the input buffer, and the amount of of flushed input in bytes.
;;; Flushes the current input buffer and any supplied replacements,
;;; and returns the input buffer, and the amount of of flushed input
;;; in bytes.
(defun flush-input-buffer (stream)
(let ((unread (if (fd-stream-unread stream)
1
0)))
(setf (fd-stream-unread stream) nil)
(let ((unread (length (fd-stream-instead stream))))
(setf (fill-pointer (fd-stream-instead stream)) 0)
(let ((ibuf (fd-stream-ibuf stream)))
(if ibuf
(let ((head (buffer-head ibuf))
......@@ -2027,16 +2043,8 @@
(do-listen)))))))
(do-listen)))
(:unread
;; If the stream is bivalent, the user might follow an
;; unread-char with a read-byte. In this case, the bookkeeping
;; is simpler if we adjust the buffer head by the number of code
;; units in the character.
;; FIXME: there has to be a proper way to check for bivalence,
;; right?
(if (fd-stream-bivalent-p fd-stream)
(decf (buffer-head (fd-stream-ibuf fd-stream))
(fd-stream-character-size fd-stream arg1))
(setf (fd-stream-unread fd-stream) arg1))
(decf (buffer-head (fd-stream-ibuf fd-stream))
(fd-stream-character-size fd-stream arg1))
(setf (fd-stream-listen fd-stream) t))
(:close
;; Drop input buffers
......@@ -2203,8 +2211,6 @@
(let ((ibuf (fd-stream-ibuf stream)))
(when ibuf
(decf posn (- (buffer-tail ibuf) (buffer-head ibuf)))))
(when (fd-stream-unread stream)
(decf posn))
;; Divide bytes by element size.
(truncate posn (fd-stream-element-size stream))))))
......
......@@ -146,7 +146,7 @@
(declare (type stream stream))
(declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
position))
;; FIXME: It woud be good to comment on the stuff that is done here...
;; FIXME: It would be good to comment on the stuff that is done here...
;; FIXME: This doesn't look interrupt safe.
(cond
(position
......@@ -548,21 +548,27 @@
;; An empty count does not necessarily mean that we reached
;; the EOF, it's also possible that it's e.g. due to a
;; invalid octet sequence in a multibyte stream. To handle
;; the resyncing case correctly we need to call the
;; single-character reading function and check whether an
;; EOF was really reached. If not, we can just fill the
;; buffer by one character, and hope that the next refill
;; will not need to resync.
(let* ((value (funcall (ansi-stream-in stream) stream nil :eof))
(index (1- +ansi-stream-in-buffer-length+)))
(case value
((:eof)
;; Mark buffer as empty.
;; the resyncing case correctly we need to call the reading
;; function and check whether an EOF was really reached. If
;; not, we can just fill the buffer by one character, and
;; hope that the next refill will not need to resync.
;;
;; KLUDGE: we can't use FD-STREAM functions (which are the
;; only ones which will give us decoding errors) here,
;; because this code is generic. We can't call the N-BIN
;; function, because near the end of a real file that can
;; legitimately bounce us to the IN function. So we have
;; to call ANSI-STREAM-IN.
(let* ((index (1- +ansi-stream-in-buffer-length+))
(value (funcall (ansi-stream-in stream) stream nil :eof)))
(cond
((eql value :eof)
;; definitely EOF now
(setf (ansi-stream-in-index stream)
+ansi-stream-in-buffer-length+)
;; EOF.
(values t (eof-or-lose stream eof-error-p eof-value)))
(otherwise
;; we resynced or were given something instead
(t
(setf (aref ibuf index) value)
(values nil (setf (ansi-stream-in-index stream) index))))))
(t
......
......@@ -78,22 +78,29 @@
(write-byte 67 s))
(with-open-file (s *test-path* :direction :input
:external-format :utf-8)
(handler-bind
((sb-int:character-decoding-error #'(lambda (decoding-error)
(declare (ignore decoding-error))
(invoke-restart
'sb-int:attempt-resync))))
(assert (equal (read-line s nil s) "ABC"))
(assert (equal (read-line s nil s) s))))
(let ((count 0))
(handler-bind
((sb-int:character-decoding-error #'(lambda (decoding-error)
(declare (ignore decoding-error))
(when (> (incf count) 1)
(error "too many errors"))
(invoke-restart
'sb-int:attempt-resync))))
(assert (equal (read-line s nil s) "ABC"))
(assert (equal (read-line s nil s) s)))))
(with-open-file (s *test-path* :direction :input
:external-format :utf-8)
(handler-bind
((sb-int:character-decoding-error #'(lambda (decoding-error)
(declare (ignore decoding-error))
(invoke-restart
'sb-int:force-end-of-file))))
(assert (equal (read-line s nil s) "AB"))
(assert (equal (read-line s nil s) s))))
(let ((count 0))
(handler-bind
((sb-int:character-decoding-error #'(lambda (decoding-error)
(declare (ignore decoding-error))
(when (> (incf count) 1)
(error "too many errors"))
(invoke-restart
'sb-int:force-end-of-file))))
(assert (equal (read-line s nil s) "AB"))
(setf count 0)
(assert (equal (read-line s nil s) s)))))
;;; And again with more data to account for buffering (this was briefly)
;;; broken in early 0.9.6.
......@@ -112,33 +119,41 @@
(with-test (:name (:character-decode-large :attempt-resync))
(with-open-file (s *test-path* :direction :input
:external-format :utf-8)
(handler-bind
((sb-int:character-decoding-error #'(lambda (decoding-error)
(let ((count 0))
(handler-bind
((sb-int:character-decoding-error (lambda (decoding-error)
(declare (ignore decoding-error))
(when (> (incf count) 1)
(error "too many errors"))
(invoke-restart
'sb-int:attempt-resync)))
;; The failure mode is an infinite loop, add a timeout to detetct it.
(sb-ext:timeout (lambda () (error "Timeout"))))
(sb-ext:with-timeout 5
(dotimes (i 80)
(assert (equal (read-line s nil s)
"1234567890123456789012345678901234567890123456789")))))))
;; The failure mode is an infinite loop, add a timeout to
;; detetct it.
(sb-ext:timeout (lambda () (error "Timeout"))))
(sb-ext:with-timeout 5
(dotimes (i 80)
(assert (equal (read-line s nil s)
"1234567890123456789012345678901234567890123456789"))))))))
(with-test (:name (:character-decode-large :force-end-of-file))
(with-open-file (s *test-path* :direction :input
:external-format :utf-8)
(handler-bind
((sb-int:character-decoding-error #'(lambda (decoding-error)
(let ((count 0))
(handler-bind
((sb-int:character-decoding-error (lambda (decoding-error)
(declare (ignore decoding-error))
(when (> (incf count) 1)
(error "too many errors"))
(invoke-restart
'sb-int:force-end-of-file)))
;; The failure mode is an infinite loop, add a timeout to detetct it.
(sb-ext:timeout (lambda () (error "Timeout"))))
(sb-ext:with-timeout 5
(dotimes (i 40)
(assert (equal (read-line s nil s)
"1234567890123456789012345678901234567890123456789")))
(assert (equal (read-line s nil s) s))))))
;; The failure mode is an infinite loop, add a timeout to detetct it.
(sb-ext:timeout (lambda () (error "Timeout"))))
(sb-ext:with-timeout 5
(dotimes (i 40)
(assert (equal (read-line s nil s)
"1234567890123456789012345678901234567890123456789")))
(setf count 0)
(assert (equal (read-line s nil s) s)))))))
;;; Test character encode restarts.
(with-open-file (s *test-path* :direction :output
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment