X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fstream.impure.lisp;h=8d0fc37ce138a422199d06248d07b341acde2c5e;hb=31f68584d0732dc0d17f379773e5f87f1e5a78ad;hp=e7036b2c247e840a8602b3945c2fe0c76d7f66d1;hpb=c7c7bab2b37d8b9fbda8f955f09540db17573afa;p=sbcl.git

diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp
index e7036b2..8d0fc37 100644
--- a/tests/stream.impure.lisp
+++ b/tests/stream.impure.lisp
@@ -80,7 +80,8 @@
                        type-error))
 (assert (raises-error? (with-open-file (s "/dev/zero")
                          (read-byte s))
-                       type-error))
+                       #-win32 type-error
+                       #+win32 sb-int:simple-file-error))
 ;;; bidirectional streams getting confused about their position
 (let ((p "bidirectional-stream-test"))
   (with-open-file (s p :direction :output :if-exists :supersede)
@@ -91,7 +92,10 @@
     (with-standard-io-syntax
       (prin1 'insert s)))
   (with-open-file (s p)
-    (assert (string= (read-line s) "THESE INSERTMBOLS")))
+    (let ((line (read-line s))
+          (want "THESE INSERTMBOLS"))
+      (unless (equal line want)
+        (error "wanted ~S, got ~S" want line))))
   (delete-file p))
 
 ;;; :DIRECTION :IO didn't work on non-existent pathnames
@@ -128,27 +132,28 @@
 
 ;;; CLOSING a non-new streams should not delete them, and superseded
 ;;; files should be restored.
-(let ((test "test-file-for-close-should-not-delete"))
-  (macrolet ((test-mode (mode)
-               `(progn
-                 (catch :close-test-exit
-                   (with-open-file (f test :direction :output :if-exists ,mode)
-                     (write-line "test" f)
-                     (throw :close-test-exit t)))
-                 (assert (and (probe-file test) ,mode)))))
-    (unwind-protect
-         (progn
-           (with-open-file (f test :direction :output)
-             (write-line "test" f))
-           (test-mode :append)
-           (test-mode :overwrite)
-           ;; FIXME: We really should recover supersede files as well, according to
-           ;; CLOSE in CLHS, but at the moment we don't.
-           ;; (test-mode :supersede)
-           (test-mode :rename)
-           (test-mode :rename-and-delete))
-      (when (probe-file test)
-        (delete-file test)))))
+(with-test (:name :test-file-for-close-should-not-delete :fails-on :win32)
+  (let ((test "test-file-for-close-should-not-delete"))
+    (macrolet ((test-mode (mode)
+                          `(progn
+                             (catch :close-test-exit
+                               (with-open-file (f test :direction :output :if-exists ,mode)
+                                               (write-line "test" f)
+                                               (throw :close-test-exit t)))
+                             (assert (and (probe-file test) ,mode)))))
+      (unwind-protect
+          (progn
+            (with-open-file (f test :direction :output)
+                            (write-line "test" f))
+            (test-mode :append)
+            (test-mode :overwrite)
+            ;; FIXME: We really should recover supersede files as well, according to
+            ;; CLOSE in CLHS, but at the moment we don't.
+            ;; (test-mode :supersede)
+            (test-mode :rename)
+            (test-mode :rename-and-delete))
+        (when (probe-file test)
+          (delete-file test))))))
 
 ;;; test for read-write invariance of signed bytes, from Bruno Haible
 ;;; cmucl-imp 2004-09-06
@@ -209,6 +214,14 @@
     (read-sequence sequence stream)
     (assert (equalp sequence #(255)))))
 
+  (let ((sequence (make-array 1)))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :external-format :latin-1
+                            :element-type 'character)
+      (read-sequence sequence stream)
+      (assert (equalp sequence #(#.(code-char 255))))))
+
   ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
   ;; 8) vectors.
   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
@@ -225,8 +238,8 @@
     (read-sequence sequence stream)
     (assert (equalp sequence #(-1)))))
 
-  ;; A bivalent stream can be read to a unsigned-byte vector or a
-  ;; string
+  ;; A bivalent stream can be read to a unsigned-byte vector, a
+  ;; string, or a generic vector
 
   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
     (with-open-file (stream pathname
@@ -243,6 +256,14 @@
       (read-sequence sequence stream)
       (assert (equalp sequence #(#.(code-char 255))))))
 
+  (let ((sequence (make-array 1)))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :external-format :latin-1
+                            :element-type :default)
+      (read-sequence sequence stream)
+      (assert (equalp sequence #(#.(code-char 255))))))
+
   ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
   ;; stream) pairs.
 
@@ -275,15 +296,16 @@
   (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
     (with-open-file (stream pathname
                             :direction :input
+                            :external-format :latin1
                             :element-type :default)
       (handler-case (progn
                       (read-sequence sequence stream)
                       (error "READ-SEQUENCE didn't signal an error"))
         (type-error (condition)
-          (assert (= (type-error-datum condition) 255))
+          (assert (eql (type-error-datum condition) (code-char 255)))
           (assert (subtypep (type-error-expected-type condition)
-                            '(signed-byte 8))))))))
-
+                            '(signed-byte 8)))))))
+  (delete-file pathname))
 
 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
 ;;; write a sequence element.
@@ -296,6 +318,8 @@
 
 (let ((pathname "write-sequence.data")
       (generic-sequence (make-array 1 :initial-contents '(255)))
+      (generic-character-sequence (make-array 1 :initial-element #\a))
+      (generic-mixed-sequence (make-array 2 :initial-element #\a))
       (string (make-array 1 :element-type 'character
                           :initial-element (code-char 255)))
       (unsigned-sequence (make-array 1
@@ -304,6 +328,9 @@
       (signed-sequence (make-array 1
                                    :element-type '(signed-byte 8)
                                    :initial-contents '(-1))))
+
+  (setf (aref generic-mixed-sequence 1) 255)
+
   ;; Check the slow path for generic vectors.
   (with-open-file (stream pathname
                            :direction :output
@@ -311,6 +338,12 @@
                            :element-type '(unsigned-byte 8))
     (write-sequence generic-sequence stream))
 
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type 'character)
+    (write-sequence generic-character-sequence stream))
+
   ;; Check the fast path for unsigned and signed vectors.
   (with-open-file (stream pathname
                           :direction :output
@@ -324,7 +357,8 @@
                           :element-type '(signed-byte 8))
     (write-sequence signed-sequence stream))
 
-  ;; Bivalent streams on unsigned-byte and strings
+  ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
+  ;; vector with mixed characters and bytes
 
   (with-open-file (stream pathname
                           :direction :output
@@ -339,6 +373,13 @@
                           :element-type :default)
     (write-sequence string stream))
 
+  (with-open-file (stream pathname
+                          :direction :output
+                          :external-format :latin-1
+                          :if-exists :supersede
+                          :element-type :default)
+    (write-sequence generic-mixed-sequence stream))
+
   ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
   ;; which are incompatible with the stream element type.
   (with-open-file (stream pathname
@@ -375,6 +416,321 @@
       (type-error (condition)
         (assert (= (type-error-datum condition) -1))
         (assert (subtypep (type-error-expected-type condition)
-                          '(unsigned-byte 8)))))))
+                          '(unsigned-byte 8))))))
+
+  (delete-file pathname))
+
+;;; writing looong lines. takes way too long and way too much space
+;;; to test on 64 bit platforms
+#-#.(cl:if (cl:= sb-vm:n-word-bits 64) '(and) '(or))
+(let ((test "long-lines-write-test.tmp"))
+    (unwind-protect
+         (with-open-file (f test
+                            :direction :output
+                            :external-format :ascii
+                            :element-type 'character
+                            :if-does-not-exist :create
+                            :if-exists :supersede)
+           (let* ((n (truncate most-positive-fixnum 16))
+                  (m 18)
+                  (p (* n m))
+                  (buffer (make-string n)))
+             (dotimes (i m)
+               (write-char #\.)
+               (finish-output)
+               (write-sequence buffer f))
+             (assert (= p (sb-impl::fd-stream-char-pos f)))
+             (write-char #\! f)
+             (assert (= (+ 1 p) (sb-impl::fd-stream-char-pos f)))
+             (assert (typep p 'bignum))))
+      (when (probe-file test)
+        (delete-file test))))
+
+;;; read-sequence misreported the amount read and lost position
+(let ((string (make-array (* 3 sb-impl::+ansi-stream-in-buffer-length+)
+                          :element-type 'character)))
+  (dotimes (i (length string))
+    (setf (char string i) (code-char (mod i char-code-limit))))
+  (with-open-file (f "read-sequence-character-test-data.tmp"
+                     :if-exists :supersede
+                     :direction :output
+                     :external-format :utf-8)
+    (write-sequence string f))
+  (let ((copy
+         (with-open-file (f "read-sequence-character-test-data.tmp"
+                            :if-does-not-exist :error
+                            :direction :input
+                            :external-format :utf-8)
+           (let ((buffer (make-array 128 :element-type 'character))
+                 (total 0))
+             (with-output-to-string (datum)
+               (loop for n-read = (read-sequence buffer f)
+                     do (write-sequence buffer datum :start 0 :end n-read)
+                        (assert (<= (incf total n-read) (length string)))
+                     while (and (= n-read 128))))))))
+    (assert (equal copy string)))
+  (delete-file "read-sequence-character-test-data.tmp"))
+
+;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's
+;;; target was an ANSI stream, but it could be a user-defined stream,
+;;; e.g., a SLIME stream.
+(defclass user-output-stream (fundamental-output-stream)
+  ())
+
+(let ((*stream* (make-instance 'user-output-stream)))
+  (declare (special *stream*))
+  (with-open-stream (stream (make-synonym-stream '*stream*))
+    (assert (output-stream-p stream))))
+
+(defclass user-input-stream (fundamental-input-stream)
+  ())
+
+(let ((*stream* (make-instance 'user-input-stream)))
+  (declare (special *stream*))
+  (with-open-stream (stream (make-synonym-stream '*stream*))
+    (assert (input-stream-p stream))))
+
+;;; READ-LINE on ANSI-STREAM did not return T for the last line
+;;; (reported by Yoshinori Tahara)
+(let ((pathname "test-read-line-eol"))
+  (with-open-file (out pathname :direction :output :if-exists :supersede)
+    (format out "a~%b"))
+  (let ((result (with-open-file (in pathname)
+                  (list (multiple-value-list (read-line in nil nil))
+                        (multiple-value-list (read-line in nil nil))
+                        (multiple-value-list (read-line in nil nil))))))
+    (delete-file pathname)
+    (assert (equal result '(("a" nil) ("b" t) (nil t))))))
+
+;;; READ-LINE used to work on closed streams because input buffers were left in place
+(with-test (:name :bug-425)
+  ;; Normal close
+  (let ((f (open "stream.impure.lisp" :direction :input)))
+    (assert (stringp (read-line f)))
+    (close f)
+    (assert (eq :fii
+                (handler-case
+                    (read-line f)
+                  (sb-int:closed-stream-error () :fii)))))
+  ;; Abort
+  (let ((f (open "stream.impure.lisp" :direction :input)))
+    (assert (stringp (read-line f nil nil)))
+    (close f :abort t)
+    (assert (eq :faa
+                (handler-case
+                    (read-line f)
+                  (sb-int:closed-stream-error () :faa))))))
+
+(with-test (:name :regression-1.0.12.22)
+  (with-open-file (s "stream.impure.lisp" :direction :input)
+    (let ((buffer (make-string 20)))
+      (assert (= 2 (read-sequence buffer s :start 0 :end 2)))
+      (assert (= 3 (read-sequence buffer s :start 2 :end 3)))
+      (file-position s :end)
+      (assert (= 3 (read-sequence buffer s :start 3))))))
+
+;;; In 1.0.27 (and also 0.9.16; presumably in between, too), binary
+;;; input operations on a bivalent stream did something bad after
+;;; unread-char: READ-BYTE would return the character, and
+;;; READ-SEQUENCE into a byte buffer would lose when attempting to
+;;; store the character in the vector.
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename)
+    (write-char #\a s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (integerp (read-byte s))))
+  (delete-file pathname))
+
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename)
+    (write-char #\a s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
+              (read-sequence buffer s))))
+  (delete-file pathname))
+
+#+sb-unicode
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename
+                     :external-format :utf8)
+    (write-char (code-char 192) s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (integerp (read-byte s))))
+  (delete-file pathname))
+
+#+sb-unicode
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename
+                     :external-format :utf8)
+    (write-char (code-char 192) s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
+              (read-sequence buffer s))))
+  (delete-file pathname))
+
+(with-test (:name :delete-file-on-streams)
+  (with-open-file (f "delete-file-on-stream-test.tmp"
+                     :direction :io)
+    (delete-file f)
+    #-win32
+    (progn
+      (write-line "still open" f)
+      (file-position f :start)
+      (assert (equal "still open" (read-line f)))))
+  (assert (not (probe-file "delete-file-on-stream-test.tmp"))))
+
+;;; READ-CHAR-NO-HANG on bivalent streams (as returned by RUN-PROGRAM)
+;;; was wrong.  CSR managed to promote the wrongness to all streams in
+;;; the 1.0.32.x series, breaking slime instantly.
+(with-test (:name :read-char-no-hang-after-unread-char :skipped-on :win32)
+  (let* ((process (run-program "/bin/sh" '("-c" "echo a && sleep 10")
+                               :output :stream :wait nil))
+         (stream (process-output process))
+         (char (read-char stream)))
+    (assert (char= char #\a))
+    (unread-char char stream)
+    (assert (char= (read-char stream) #\a))
+    (assert (char= (read-char stream) #\Newline))
+    (let ((time (get-universal-time)))
+      ;; no input, not yet known to be at EOF: should return
+      ;; immediately
+      (read-char-no-hang stream)
+      (assert (< (- (get-universal-time) time) 2)))))
+
+(require :sb-posix)
+#-win32
+(with-test (:name :interrupt-open :skipped-on :win32)
+  (let ((fifo nil)
+        (to 0))
+    (unwind-protect
+         (progn
+           ;; Make a FIFO
+           (setf fifo (sb-posix:mktemp "SBCL-fifo.XXXXXXX"))
+           (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
+           ;; Try to open it (which hangs), and interrupt ourselves with a timer,
+           ;; continue (this used to result in an error due to open(2) returning with
+           ;; EINTR, then interupt again and unwind.
+           (handler-case
+               (with-timeout 2
+                 (handler-bind ((timeout (lambda (c)
+                                           (when (eql 1 (incf to))
+                                             (continue c)))))
+                   (with-timeout 1
+                     (with-open-file (f fifo :direction :input)
+                       :open))))
+             (timeout ()
+               (if (eql 2 to)
+                   :timeout
+                   :wtf))
+             (error (e)
+               e)))
+      (when fifo
+        (ignore-errors (delete-file fifo))))))
+
+#-win32
+(with-test (:name :overeager-character-buffering :skipped-on :win32)
+  (let ((fifo nil)
+        (proc nil))
+    (maphash
+     (lambda (format _)
+       (declare (ignore _))
+       (format t "trying ~A~%" format)
+       (finish-output t)
+       (unwind-protect
+            (progn
+              (setf fifo (sb-posix:mktemp "SBCL-fifo-XXXXXXX"))
+              (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
+              ;; KLUDGE: because we have both ends in the same process, we would
+              ;; need to use O_NONBLOCK, but this works too.
+              (setf proc
+                    (run-program "/bin/sh"
+                                 (list "-c"
+                                       (format nil "cat > ~A" (native-namestring fifo)))
+                                 :input :stream
+                                 :wait nil
+                                 :external-format format))
+              (write-line "foobar" (process-input proc))
+              (finish-output (process-input proc))
+              (with-open-file (f fifo :direction :input :external-format format)
+                (assert (equal "foobar" (read-line f)))))
+         (when proc
+           (ignore-errors
+             (close (process-input proc) :abort t)
+             (process-wait proc))
+           (ignore-errors (process-close proc))
+           (setf proc nil))
+         (when fifo
+           (ignore-errors (delete-file fifo))
+           (setf fifo nil))))
+     sb-impl::*external-formats*)))
+
+(with-test (:name :bug-657183 :skipped-on '(not :sb-unicode))
+  #+sb-unicode
+  (let ((name (merge-pathnames "stream-impure.temp-test"))
+        (text '(#\GREEK_SMALL_LETTER_LAMDA
+                #\JAPANESE_BANK_SYMBOL
+                #\Space
+                #\HEAVY_BLACK_HEART))
+        (positions '(2 5 6 9))
+        (sb-impl::*default-external-format* :utf-8))
+    (unwind-protect
+         (progn
+           (with-open-file (f name :external-format :default :direction :output
+                              :if-exists :supersede)
+             (assert (eql 0 (file-position f)))
+             (mapc (lambda (char pos)
+                     (write-char char f)
+                     (assert (eql pos (file-position f))))
+                   text
+                   positions))
+           (with-open-file (f name :external-format :default :direction :input)
+             (assert (eql 0 (file-position f)))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 2))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 5))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 6))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 9))
+             (assert (eql (file-length f) 9))))
+      (ignore-errors (delete-file name)))))
+
+(with-test (:name :bug-561642)
+  (let ((p "bug-561642-test.tmp"))
+    (unwind-protect
+         (progn
+           (with-open-file (f p
+                              :if-exists :supersede
+                              :if-does-not-exist :create
+                              :direction :output)
+             (write-line "FOOBAR" f))
+           (with-open-file (f p
+                              :if-exists :append
+                              :direction :output)
+             (let ((p0 (file-position f))
+                   (p1 (progn
+                         (write-char #\newline f)
+                         (file-position f)))
+                   (p2 (progn
+                         (write-char #\newline f)
+                         (finish-output f)
+                         (file-position f))))
+               (assert (eql 7 p0))
+               (assert (eql 8 p1))
+               (assert (eql 9 p2)))))
+      (ignore-errors (delete-file p)))))
 
 ;;; success