tests/bivalent-stream.pure.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   (declare (ignore file))
  30   (let ((file-var (gensym)))
  31     `(let ((,file-var (scratch-file-name)))
  32        (unwind-protect
  33             (macrolet
  34                 ((with-stream ((stream &rest args &key &allow-other-keys) &body body)
  35                    `(with-open-file (,stream ,',file-var ,@args
  36                                              :element-type :default :external-format :utf-8)
  37                       ,@body)))
  38               ,@body)
  39          (when (probe-file ,file-var)
  40            (delete-file ,file-var))))))
  41
  42 (defun assert-roundtrip (write-call read-call result expected)
  43   (unless (equalp result expected)
  44     (error "~@<Writing via ~S and reading back via ~S produced ~S, ~
  45             expected ~S.~@:>"
  46            write-call read-call result expected)))
  47
  48 (defun zero-string (n) (make-string n :initial-element #\nul))
  49
  50 (defvar *read/write-sequence-pairs*
  51   `(;; List source and destination sequence.
  52     ((65)       ()         ,(list 0)        ()         1 (#\A))
  53     ((#\B)      ()         ,(list 0)        ()         1 (#\B))
  54     ((#x7e)     ()         ,(list 0)        ()         1 (,(code-char #x7e)))
  55     ((66 #\C)   ()         ,(list 0 0)      ()         2 (#\B #\C))
  56     ((#\B 67)   ()         ,(list 0 0)      ()         2 (#\B #\C))
  57     ((#\B #\C)  (:start 1) ,(list 0)        ()         1 (#\C))
  58     ((#\B #\C)  (:end 1)   ,(list 0)        ()         1 (#\B))
  59     ((#\B)      ()         ,(list 0 0)      (:start 1) 2 (0 #\B))
  60     ((#\B)      ()         ,(list 0 0)      (:end 1)   1 (#\B 0))
  61     ;; Vector source sequence.
  62     (#(65)      ()         ,(list 0)        ()         1 (#\A))
  63     (#(#\B)     ()         ,(list 0)        ()         1 (#\B))
  64     (#(#x7e)    ()         ,(list 0)        ()         1 (,(code-char #x7e)))
  65     (#(66 #\C)  ()         ,(list 0 0)      ()         2 (#\B #\C))
  66     (#(#\B 67)  ()         ,(list 0 0)      ()         2 (#\B #\C))
  67     (#(#\B #\C) (:end 1)   ,(list 0)        ()         1 (#\B))
  68     (#(#\B #\C) (:start 1) ,(list 0)        ()         1 (#\C))
  69     ;; String source sequence.
  70     ("A"        ()         ,(list 0)        ()         1 (#\A))
  71     ("B"        ()         ,(list 0)        ()         1 (#\B))
  72     ("BC"       (:start 1) ,(list 0)        ()         1 (#\C))
  73     ("BC"       (:end 1)   ,(list 0)        ()         1 (#\B))
  74     ;; Generic vector destination sequence.
  75     (#(65)      ()         ,(vector 0)      ()         1 #(#\A))
  76     (#(#\B)     ()         ,(vector 0)      ()         1 #(#\B))
  77     (#(#x7e)    ()         ,(vector 0)      ()         1 #(,(code-char #x7e)))
  78     (#(66 #\C)  ()         ,(vector 0 0)    ()         2 #(#\B #\C))
  79     (#(#\B 67)  ()         ,(vector 0 0)    ()         2 #(#\B #\C))
  80     (#(#\B)     ()         ,(vector 0 0)    (:end 1)   1 #(#\B 0))
  81     (#(#\B)     ()         ,(vector 0 0)    (:start 1) 2 #(0 #\B))
  82     ;; Byte-vector destination sequence.
  83     (#(65)      ()         ,(bvector 0)     ()         1 #(65))
  84     (#(#\B)     ()         ,(bvector 0)     ()         1 #(66))
  85     (#(#xe0)    ()         ,(bvector 0)     ()         1 #(#xe0))
  86     (#(66 #\C)  ()         ,(bvector 0 0)   ()         2 #(66 67))
  87     (#(#\B 67)  ()         ,(bvector 0 0)   ()         2 #(66 67))
  88     (#(#\B)     ()         ,(bvector 0 0)   (:end 1)   1 #(66 0))
  89     (#(#\B)     ()         ,(bvector 0 0)   (:start 1) 2 #(0 66))
  90     ;; Character-vector destination sequence.
  91     (#(65)      ()         ,(cvector #\_)     ()         1 #(#\A))
  92     (#(#\B)     ()         ,(cvector #\_)     ()         1 #(#\B))
  93     (#(#x7e)    ()         ,(cvector #\_)     ()         1 #(,(code-char #x7e)))
  94     (#(66 #\C)  ()         ,(cvector #\_ #\_) ()         2 #(#\B #\C))
  95     (#(#\B 67)  ()         ,(cvector #\_ #\_) ()         2 #(#\B #\C))
  96     (#(#\B)     ()         ,(cvector #\_ #\_) (:end 1)   1 #(#\B #\_))
  97     (#(#\B)     ()         ,(cvector #\_ #\_) (:start 1) 2 #(#\_ #\B))
  98     ;; String destination sequence.
  99     (#(65)      ()         ,(zero-string 1)   ()         1 "A")
 100     (#(#\B)     ()         ,(zero-string 1)   ()         1 "B")
 101     (#(66 #\C)  ()         ,(zero-string 2)   ()         2 "BC")
 102     (#(#\B 67)  ()         ,(zero-string 2)   ()         2 "BC")
 103     (#(#\B)     ()         ,(zero-string 2)   (:end 1)   1 ,(coerce '(#\B #\Nul) 'string))
 104     (#(#\B)     ()         ,(zero-string 2)   (:start 1) 2 ,(coerce '(#\Nul #\B) 'string))))
 105
 106 (defun do-writes (stream pairs)
 107   (loop :for (sequence args) :in pairs
 108      :do (apply #'write-sequence sequence stream args)))
 109
 110 (defun do-reads (stream pairs)
 111   (loop :for (source source-args into into-args
 112               expected-position expected-sequence) :in pairs
 113      :do (let ((into/old (copy-seq into))
 114                (position (apply #'read-sequence into stream into-args)))
 115            (unless (= position expected-position)
 116              (error "~@<~S returned ~S, expected ~S.~@:>"
 117                     `(read-sequence ,into/old ,@into-args)
 118                     position expected-position))
 119            (assert-roundtrip `(write-sequence ,source ,@source-args)
 120                              `(read-sequence ,into/old ,@into-args)
 121                              into expected-sequence))))
 122
 123 (with-test (:name (stream :bivalent :roundtrip :element))
 124   (let ((pairs '((write-byte 65   read-char #\A)
 125                  (write-char #\B  read-byte 66)
 126                  (write-byte #xe0 read-byte #xe0)
 127                  (write-char #\C  read-char #\C))))
 128     (with-bivalent-io-setup ("bivalent-stream-test.txt")
 129       (with-stream (stream :direction :output :if-exists :supersede)
 130         (loop :for (function argument) :in pairs
 131            :do (funcall function argument stream)))
 132
 133       (with-stream (stream :direction :input)
 134         (loop :for (write-function write-arg read-function expected) :in pairs
 135            :do (let ((result (funcall read-function stream)))
 136                  (assert-roundtrip `(,write-function ,write-arg)
 137                                    `(,read-function)
 138                                    result expected)))))))
 139
 140 (with-test (:name (stream :bivalent :roundtrip sequence))
 141   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 142     ;; Write sequence.
 143     (with-stream (stream :direction :output :if-exists :supersede)
 144       (do-writes stream *read/write-sequence-pairs*))
 145     ;; Read sequence and compare.
 146     (with-stream (stream :direction :input)
 147       (do-reads stream *read/write-sequence-pairs*))))
 148
 149 (defvar *synonym-stream-stream*)
 150 (with-test (:name (stream :bivalent :roundtrip sequence synonym-stream))
 151   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 152     ;; Write sequence.
 153     (with-stream (stream :direction :output :if-exists :supersede)
 154       (let ((*synonym-stream-stream* stream)
 155             (stream (make-synonym-stream '*synonym-stream-stream*)))
 156         (do-writes stream *read/write-sequence-pairs*)))
 157     ;; Read sequence and compare.
 158     (with-stream (stream :direction :input)
 159       (let ((*synonym-stream-stream* stream)
 160             (stream (make-synonym-stream '*synonym-stream-stream*)))
 161        (do-reads stream *read/write-sequence-pairs*)))))
 162
 163 (with-test (:name (stream :bivalent :roundtrip sequence broadcast-stream))
 164   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 165     ;; Write sequence.
 166     (with-stream (stream :direction :output :if-exists :supersede)
 167       (let ((stream (make-broadcast-stream stream)))
 168         (do-writes stream *read/write-sequence-pairs*)))
 169     ;; Read sequence and compare.
 170     (with-stream (stream :direction :input)
 171       (do-reads stream *read/write-sequence-pairs*))))
 172
 173 (with-test (:name (stream :bivalent :roundtrip sequence echo-stream))
 174   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 175     ;; Write sequence.
 176     (with-stream (stream :direction :output :if-exists :supersede)
 177       (do-writes stream *read/write-sequence-pairs*))
 178     ;; Read sequence and compare.
 179     (with-stream (stream :direction :input)
 180       (let ((stream (make-echo-stream stream (make-broadcast-stream))))
 181         (do-reads stream *read/write-sequence-pairs*)))))
 182
 183 (with-test (:name (stream :bivalent :roundtrip sequence two-way-stream))
 184   (with-bivalent-io-setup ("bivalent-stream-test.txt")
 185     ;; Write sequence.
 186     (with-stream (stream :direction :output :if-exists :supersede)
 187       (let ((stream (make-two-way-stream (make-concatenated-stream) stream)))
 188         (do-writes stream *read/write-sequence-pairs*)))
 189     ;; Read sequence and compare.
 190     (with-stream (stream :direction :input)
 191       (let ((stream (make-two-way-stream stream (make-broadcast-stream))))
 192         (do-reads stream *read/write-sequence-pairs*)))))
 193
 194 (with-test (:name (stream :bivalent synonym-stream *standard-input* *standard-output*))
 195   (assert (eq (sb-impl::stream-element-mode *standard-input*) :bivalent))
 196   (assert (eq (sb-impl::stream-element-mode *standard-output*) :bivalent)))
 197
 198 (with-test (:name (stream :bivalent :no-unknown-type-condition))
 199   (assert-no-signal
 200    (with-bivalent-io-setup ("bivalent-stream-test.txt")
 201      (with-stream (stream :direction :output :if-exists :supersede)))
 202    sb-kernel:parse-unknown-type))