From: Juho Snellman Date: Wed, 15 Mar 2006 04:21:03 +0000 (+0000) Subject: 0.9.10.33: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=550f09b2bbea9495931a9e964dfeea5ca7d38aff;p=sbcl.git 0.9.10.33: Fix CL:LISTEN to always return NIL at EOF, as required by CLTS. (Patch by Stephen Compall on sbcl-devel "Re: fd-stream listen in fd-stream-misc-routine") (Also "oops". I somehow attributed 0.9.10.32 to the wrong James). --- diff --git a/NEWS b/NEWS index 0401dcc..c964bac 100644 --- a/NEWS +++ b/NEWS @@ -27,7 +27,9 @@ changes in sbcl-0.9.11 relative to sbcl-0.9.10: calls of MAKE-ARRAY, bound to variables, declared DYNAMIC-EXTENT * enchancement: the PROCESS-INPUT and -OUTPUT streams created by SB-EXT:RUN-PROGRAM can be used for both character and byte IO - (thanks to James Bielman) + (thanks to James Knight) + * fixed bug: CL:LISTEN always returns NIL at end of file, as required + by the standard (thanks to Stephen Compall) changes in sbcl-0.9.10 relative to sbcl-0.9.9: * new feature: new SAVE-LISP-AND-DIE keyword argument :EXECUTABLE can diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 4d87332..3edf77e 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -635,6 +635,33 @@ ;;; per element. (defvar *input-routines* ()) +;;; Return whether a primitive partial read operation on STREAM's FD +;;; would (probably) block. Signal a `simple-stream-error' if the +;;; system call implementing this operation fails. +;;; +;;; It is "may" instead of "would" because "would" is not quite +;;; correct on win32. However, none of the places that use it require +;;; further assurance than "may" versus "will definitely not". +(defun sysread-may-block-p (stream) + #+win32 + ;; This answers T at EOF on win32, I think. + (not (sb!win32:fd-listen (fd-stream-fd stream))) + #-win32 + (sb!unix:with-restarted-syscall (count errno) + (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) + (sb!unix:fd-zero read-fds) + (sb!unix:fd-set (fd-stream-fd stream) read-fds) + (sb!unix:unix-fast-select (1+ (fd-stream-fd stream)) + (sb!alien:addr read-fds) + nil nil 0 0)) + (case count + ((1) nil) + ((0) t) + (otherwise + (simple-stream-perror "couldn't check whether ~S is readable" + stream + errno))))) + ;;; Fill the input buffer, and return the number of bytes read. Throw ;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into ;;; SYSTEM:SERVER if necessary. @@ -659,35 +686,13 @@ (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) tail)))) (setf (fd-stream-listen stream) nil) - #!+win32 - (unless (sb!win32:fd-listen fd) + ;;This isn't quite the same on win32. Then again, neither was + ;;(not (sb!win32:fd-listen fd)), as was originally here. See + ;;comment in `sysread-may-block-p'. + (when (sysread-may-block-p stream) (unless (sb!sys:wait-until-fd-usable fd :input (fd-stream-timeout stream)) (error 'io-timeout :stream stream :direction :read))) - #!-win32 - (sb!unix:with-restarted-syscall (count errno) - ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands - ;; into something which uses the not-yet-defined type - ;; (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))). - ;; This is probably inefficient and unsafe and generally bad, so - ;; try to find some way to make that type known before - ;; this is compiled. - (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set fd read-fds) - (sb!unix:unix-fast-select (1+ fd) - (sb!alien:addr read-fds) - nil nil 0 0)) - (case count - (1) - (0 - (unless (sb!sys:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read))) - (t - (simple-stream-perror "couldn't check whether ~S is readable" - stream - errno)))) (multiple-value-bind (count errno) (sb!unix:unix-read fd (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail)) @@ -1585,15 +1590,19 @@ (sb!win32:fd-listen (fd-stream-fd fd-stream))) #!-win32 (setf (fd-stream-listen fd-stream) - (eql (sb!unix:with-restarted-syscall () - (sb!alien:with-alien ((read-fds (sb!alien:struct - sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) - (sb!alien:addr read-fds) - nil nil 0 0))) - 1)))) + (if (sysread-may-block-p fd-stream) + nil + ;; select(2) and CL:LISTEN have slightly different + ;; semantics. The former returns that an FD is + ;; readable when a read operation wouldn't block. + ;; That includes EOF. However, LISTEN must return + ;; NIL at EOF. + (progn (catch 'eof-input-catcher + ;; r-b/f too calls select, but it shouldn't + ;; block as long as read can return once w/o + ;; blocking + (refill-buffer/fd fd-stream)) + (fd-stream-listen fd-stream)))))) (:unread (setf (fd-stream-unread fd-stream) arg1) (setf (fd-stream-listen fd-stream) t)) @@ -1680,20 +1689,11 @@ #!-win32 (catch 'eof-input-catcher (loop - (let ((count (sb!unix:with-restarted-syscall () - (sb!alien:with-alien ((read-fds (sb!alien:struct - sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) - (sb!alien:addr read-fds) - nil nil 0 0))))) - (cond ((eql count 1) - (refill-buffer/fd fd-stream) - (setf (fd-stream-ibuf-head fd-stream) 0) - (setf (fd-stream-ibuf-tail fd-stream) 0)) - (t - (return t))))))) + until (sysread-may-block-p fd-stream) + do (refill-buffer/fd fd-stream) + (setf (fd-stream-ibuf-head fd-stream) 0) + (setf (fd-stream-ibuf-tail fd-stream) 0)) + t)) (:force-output (flush-output-buffer fd-stream)) (:finish-output diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index 9e9d914..bd2f071 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -299,3 +299,36 @@ (assert (char= (peek-char t (make-string-input-stream " a")) #\a)) (set-syntax-from-char #\Space #\a) (assert (char= (peek-char t (make-string-input-stream " a")) #\Space))) + +;;; It is actually easier to run into the problem exercised by this +;;; test with sockets, due to their delays between availabilities of +;;; data. However edgy the case may be for normal files, however, +;;; there is still a case to be found in which CL:LISTEN answers +;;; improperly. +;;; +;;; This test assumes that buffering is still done until a buffer of +;;; SB-IMPL::BYTES-PER-BUFFER bytes is filled up, that the buffer may +;;; immediately be completely filled for normal files, and that the +;;; buffer-fill routine is responsible for figuring out when we've +;;; reached EOF. +(with-test (:name (stream listen-vs-select)) + (let ((listen-testfile-name "stream.impure.lisp.testqfile") + ;; If non-NIL, size (in bytes) of the file that will exercise + ;; the LISTEN problem. + (bytes-per-buffer-sometime + (and (boundp 'sb-impl::bytes-per-buffer) + (symbol-value 'sb-impl::bytes-per-buffer)))) + (when bytes-per-buffer-sometime + (unwind-protect + (progn + (with-open-file (stream listen-testfile-name + :direction :output :if-exists :error + :element-type '(unsigned-byte 8)) + (dotimes (n bytes-per-buffer-sometime) + (write-byte 113 stream))) + (with-open-file (stream listen-testfile-name + :direction :input :element-type '(unsigned-byte 8)) + (dotimes (n bytes-per-buffer-sometime) + (read-byte stream)) + (assert (not (listen stream))))) + (ignore-errors (delete-file listen-testfile-name)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 5e800f1..d8c6441 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.10.32" +"0.9.10.33"