tests/bivalent-stream.impure.lisp

   1 ;;;; This file is for testing bivalent stream functionality, using
   2 ;;;; test machinery which might have side effects (e.g.  executing
   3 ;;;; DEFUN, writing files).  Note that the tests here might reach into
   4 ;;;; unexported functionality, and should not be used as a guide for
   5 ;;;; users.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; While most of SBCL is derived from the CMU CL system, the test
  11 ;;;; files (like this one) were written from scratch after the fork
  12 ;;;; from CMU CL.
  13 ;;;;
  14 ;;;; This software is in the public domain and is provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  16 ;;;; more information.
  17
  18 ;;; Test character decode restarts.
  19
  20 (defun bvector (&rest elements)
  21   (make-array (length elements) :element-type '(unsigned-byte 8)
  22               :initial-contents elements))
  23
  24 (defun cvector (&rest elements)
  25   (make-array (length elements) :element-type 'character
  26               :initial-contents elements))
  27
  28 (defmacro with-bivalent-io-setup ((file) &body body)
  29   (let ((file-var (gensym)))
  30     `(let ((,file-var ,file))
  31        (unwind-protect
  32             (macrolet
  33                 ((with-stream ((stream &rest args &key &allow-other-keys) &body body)
  34                    `(with-open-file (,stream ,',file-var ,@args
  35                                              :element-type :default :external-format :utf-8)
  36                       ,@body)))
  37               ,@body)
  38          (when (probe-file ,file-var)
  39            (delete-file ,file-var))))))
  40
  41 (defun assert-roundtrip (write-call read-call result expected)
  42   (unless (equalp result expected)
  43     (error "~@<Writing via ~S and reading back via ~S produced ~S, ~
  44             expected ~S.~@:>"
  45            write-call read-call result expected)))
  46
  47 (defvar *read/write-sequence-pairs*
  48   `(;; List source and destination sequence.
  49     ((65)       ()         ,(list 0)        ()         1 (#\A))
  50     ((#\B)      ()         ,(list 0)        ()         1 (#\B))
  51     ((#x7e)     ()         ,(list 0)        ()         1 (,(code-char #x7e)))
  52     ((66 #\C)   ()         ,(list 0 0)      ()         2 (#\B #\C))
  53     ((#\B 67)   ()         ,(list 0 0)      ()         2 (#\B #\C))
  54     ((#\B #\C)  (:start 1) ,(list 0)        ()         1 (#\C))
  55     ((#\B #\C)  (:end 1)   ,(list 0)        ()         1 (#\B))
  56     ((#\B)      ()         ,(list 0 0)      (:start 1) 2 (0 #\B))
  57     ((#\B)      ()         ,(list 0 0)      (:end 1)   1 (#\B 0))
  58     ;; Vector source sequence.
  59     (#(65)      ()         ,(list 0)        ()         1 (#\A))
  60     (#(#\B)     ()         ,(list 0)        ()         1 (#\B))
  61     (#(#x7e)    ()         ,(list 0)        ()         1 (,(code-char #x7e)))
  62     (#(66 #\C)  ()         ,(list 0 0)      ()         2 (#\B #\C))
  63     (#(#\B 67)  ()         ,(list 0 0)      ()         2 (#\B #\C))
  64     (#(#\B #\C) (:end 1)   ,(list 0)        ()         1 (#\B))
  65     (#(#\B #\C) (:start 1) ,(list 0)        ()         1 (#\C))
  66     ;; String source sequence.
  67     ("A"        ()         ,(list 0)        ()         1 (#\A))
  68     ("B"        ()         ,(list 0)        ()         1 (#\B))
  69     ("BC"       (:start 1) ,(list 0)        ()         1 (#\C))
  70     ("BC"       (:end 1)   ,(list 0)        ()         1 (#\B))
  71     ;; Generic vector destination sequence.
  72     (#(65)      ()         ,(vector 0)      ()         1 #(#\A))
  73     (#(#\B)     ()         ,(vector 0)      ()         1 #(#\B))
  74     (#(#x7e)    ()         ,(vector 0)      ()         1 #(,(code-char #x7e)))
  75     (#(66 #\C)  ()         ,(vector 0 0)    ()         2 #(#\B #\C))
  76     (#(#\B 67)  ()         ,(vector 0 0)    ()         2 #(#\B #\C))
  77     (#(#\B)     ()         ,(vector 0 0)    (:end 1)   1 #(#\B 0))
  78     (#(#\B)     ()         ,(vector 0 0)    (:start 1) 2 #(0 #\B))
  79     ;; Byte-vector destination sequence.
  80     (#(65)      ()         ,(bvector 0)     ()         1 #(65))
  81     (#(#\B)     ()         ,(bvector 0)     ()         1 #(66))
  82     (#(#xe0)    ()         ,(bvector 0)     ()         1 #(#xe0))
  83     (#(66 #\C)  ()         ,(bvector 0 0)   ()         2 #(66 67))
  84     (#(#\B 67)  ()         ,(bvector 0 0)   ()         2 #(66 67))
  85     (#(#\B)     ()         ,(bvector 0 0)   (:end 1)   1 #(66 0))
  86     (#(#\B)     ()         ,(bvector 0 0)   (:start 1) 2 #(0 66))
  87     ;; Character-vector destination sequence.
  88     (#(65)      ()         ,(cvector #\_)     ()         1 #(#\A))
  89     (#(#\B)     ()         ,(cvector #\_)     ()         1 #(#\B))
  90     (#(#x7e)    ()         ,(cvector #\_)     ()         1 #(,(code-char #x7e)))
  91     (#(66 #\C)  ()         ,(cvector #\_ #\_) ()         2 #(#\B #\C))
  92     (#(#\B 67)  ()         ,(cvector #\_ #\_) ()         2 #(#\B #\C))
  93     (#(#\B)     ()         ,(cvector #\_ #\_) (:end 1)   1 #(#\B #\_))
  94     (#(#\B)     ()         ,(cvector #\_ #\_) (:start 1) 2 #(#\_ #\B))
  95     ;; String destination sequence.
  96     (#(65)      ()         ,(make-string 1)   ()         1 "A")
  97     (#(#\B)     ()         ,(make-string 1)   ()         1 "B")
  98     (#(66 #\C)  ()         ,(make-string 2)   ()         2 "BC")
  99     (#(#\B 67)  ()         ,(make-string 2)   ()         2 "BC")
 100     (#(#\B)     ()         ,(make-string 2)   (:end 1)   1 ,(coerce '(#\B #\Nul) 'string))
 101     (#(#\B)     ()         ,(make-string 2)   (:start 1) 2 ,(coerce '(#\Nul #\B) 'string))))
 102
 103 (defun do-writes (stream pairs)
 104   (loop :for (sequence args) :in pairs
 105      :do (apply #'write-sequence sequence stream args)))
 106
 107 (defun do-reads (stream pairs)
 108   (loop :for (source source-args into into-args
 109               expected-position expected-sequence) :in pairs
 110      :do (let ((into/old (copy-seq into))
 111                (position (apply #'read-sequence into stream into-args)))
 112            (unless (= position expected-position)
 113              (error "~@<~S returned ~S, expected ~S.~@:>"
 114                     `(read-sequence ,into/old ,@into-args)
 115                     position expected-position))
 116            (assert-roundtrip `(write-sequence ,source ,@source-args)
 117                              `(read-sequence ,into/old ,@into-args)
 118                              into expected-sequence))))
 119
 120 (with-test (:name (stream :bivalent :roundtrip :element))
 121   (let ((pairs '((write-byte 65   read-char #\A)
 122                  (write-char #\B  read-byte 66)
 123                  (write-byte #xe0 read-byte #xe0)
 124                  (write-char #\C  read-char #\C))))
 125     (with-bivalent-io-setup ("bivalent-stream-test.txt")
 126       (with-stream (stream :direction :output :if-exists :supersede)
 127         (loop :for (function argument) :in pairs
 128            :do (funcall function argument stream)))
 129
 130       (with-stream (stream :direction :input)
 131         (loop :for (write-function write-arg read-function expected) :in pairs
 132            :do (let ((result (funcall read-function stream)))
 133                  (assert-roundtrip `(,write-function ,write-arg)
 134                                    `(,read-function)
 135                                    result expected)))))))
 136
 137 (with-test (:name (stream :bivalent :roundtrip sequence))
 138   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 139     ;; Write sequence.
 140     (with-stream (stream :direction :output :if-exists :supersede)
 141       (do-writes stream *read/write-sequence-pairs*))
 142     ;; Read sequence and compare.
 143     (with-stream (stream :direction :input)
 144       (do-reads stream *read/write-sequence-pairs*))))
 145
 146 (defvar *synonym-stream-stream*)
 147 (with-test (:name (stream :bivalent :roundtrip sequence synonym-stream))
 148   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 149     ;; Write sequence.
 150     (with-stream (stream :direction :output :if-exists :supersede)
 151       (let ((*synonym-stream-stream* stream)
 152             (stream (make-synonym-stream '*synonym-stream-stream*)))
 153         (do-writes stream *read/write-sequence-pairs*)))
 154     ;; Read sequence and compare.
 155     (with-stream (stream :direction :input)
 156       (let ((*synonym-stream-stream* stream)
 157             (stream (make-synonym-stream '*synonym-stream-stream*)))
 158        (do-reads stream *read/write-sequence-pairs*)))))
 159
 160 (with-test (:name (stream :bivalent :roundtrip sequence broadcast-stream))
 161   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 162     ;; Write sequence.
 163     (with-stream (stream :direction :output :if-exists :supersede)
 164       (let ((stream (make-broadcast-stream stream)))
 165         (do-writes stream *read/write-sequence-pairs*)))
 166     ;; Read sequence and compare.
 167     (with-stream (stream :direction :input)
 168       (do-reads stream *read/write-sequence-pairs*))))
 169
 170 (with-test (:name (stream :bivalent :roundtrip sequence echo-stream))
 171   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 172     ;; Write sequence.
 173     (with-stream (stream :direction :output :if-exists :supersede)
 174       (do-writes stream *read/write-sequence-pairs*))
 175     ;; Read sequence and compare.
 176     (with-stream (stream :direction :input)
 177       (let ((stream (make-echo-stream stream (make-broadcast-stream))))
 178         (do-reads stream *read/write-sequence-pairs*)))))
 179
 180 (with-test (:name (stream :bivalent :roundtrip sequence two-way-stream))
 181   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 182     ;; Write sequence.
 183     (with-stream (stream :direction :output :if-exists :supersede)
 184       (let ((stream (make-two-way-stream (make-concatenated-stream) stream)))
 185         (do-writes stream *read/write-sequence-pairs*)))
 186     ;; Read sequence and compare.
 187     (with-stream (stream :direction :input)
 188       (let ((stream (make-two-way-stream stream (make-broadcast-stream))))
 189         (do-reads stream *read/write-sequence-pairs*)))))
 190
 191 (with-test (:name (stream :bivalent synonym-stream *standard-input* *standard-output*))
 192   (assert (eq (sb-impl::stream-element-mode *standard-input*) :bivalent))
 193   (assert (eq (sb-impl::stream-element-mode *standard-output*) :bivalent)))
 194
 195 (with-test (:name (stream :bivalent :no-unknown-type-condition))
 196   (assert-no-signal
 197    (with-bivalent-io-setup ("bivalent-stream-test.txt")
 198      (with-stream (stream :direction :output :if-exists :supersede)))
 199    sb-kernel:parse-unknown-type))