tests/gray-streams.impure.lisp

   1 ;;;; tests related to Gray streams
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (cl:in-package :cl-user)
  15 \f
  16 ;;;; class precedence tests
  17
  18 (assert (subtypep 'fundamental-stream 'stream))
  19 (assert (subtypep 'fundamental-stream 'standard-object))
  20
  21 (assert (subtypep 'fundamental-input-stream 'fundamental-stream))
  22 (assert (subtypep 'fundamental-output-stream 'fundamental-stream))
  23 (assert (subtypep 'fundamental-character-stream 'fundamental-stream))
  24 (assert (subtypep 'fundamental-binary-stream 'fundamental-stream))
  25
  26 (assert (subtypep 'fundamental-character-input-stream
  27                   'fundamental-input-stream))
  28 (assert (subtypep 'fundamental-character-input-stream
  29                   'fundamental-character-stream))
  30 (assert (subtypep 'fundamental-character-output-stream
  31                   'fundamental-output-stream))
  32 (assert (subtypep 'fundamental-character-output-stream
  33                   'fundamental-character-stream))
  34
  35 (assert (subtypep 'fundamental-binary-input-stream
  36                   'fundamental-input-stream))
  37 (assert (subtypep 'fundamental-binary-input-stream
  38                   'fundamental-binary-stream))
  39 (assert (subtypep 'fundamental-binary-output-stream
  40                   'fundamental-output-stream))
  41 (assert (subtypep 'fundamental-binary-output-stream
  42                   'fundamental-binary-stream))
  43
  44 (defvar *fundamental-input-stream-instance*
  45   (make-instance 'fundamental-input-stream))
  46
  47 (defvar *fundamental-output-stream-instance*
  48   (make-instance 'fundamental-output-stream))
  49
  50 (defvar *fundamental-character-stream-instance*
  51   (make-instance 'fundamental-character-stream))
  52
  53 (assert (input-stream-p *fundamental-input-stream-instance*))
  54 (assert (output-stream-p *fundamental-output-stream-instance*))
  55 (assert (eql (stream-element-type
  56               *fundamental-character-stream-instance*)
  57              'character))
  58 \f
  59 ;;;; example character input and output streams
  60
  61 (defclass character-output-stream (fundamental-character-output-stream)
  62   ((lisp-stream :initarg :lisp-stream
  63                 :accessor character-output-stream-lisp-stream)
  64    (position :initform 42 :accessor character-output-stream-position)))
  65
  66 (defclass character-input-stream (fundamental-character-input-stream)
  67   ((lisp-stream :initarg :lisp-stream
  68                 :accessor character-input-stream-lisp-stream)))
  69 \f
  70 ;;;; example character output stream encapsulating a lisp-stream
  71
  72 (defun make-character-output-stream (lisp-stream)
  73   (make-instance 'character-output-stream :lisp-stream lisp-stream))
  74
  75 (defmethod open-stream-p ((stream character-output-stream))
  76   (open-stream-p (character-output-stream-lisp-stream stream)))
  77
  78 (defmethod close ((stream character-output-stream) &key abort)
  79   (close (character-output-stream-lisp-stream stream) :abort abort))
  80
  81 (defmethod input-stream-p ((stream character-output-stream))
  82   (input-stream-p (character-output-stream-lisp-stream stream)))
  83
  84 (defmethod output-stream-p ((stream character-output-stream))
  85   (output-stream-p (character-output-stream-lisp-stream stream)))
  86
  87 (defmethod stream-write-char ((stream character-output-stream) character)
  88   (write-char character (character-output-stream-lisp-stream stream)))
  89
  90 (defmethod stream-line-column ((stream character-output-stream))
  91   (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
  92
  93 (defmethod stream-line-length ((stream character-output-stream))
  94   (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
  95
  96 (defmethod stream-finish-output ((stream character-output-stream))
  97   (finish-output (character-output-stream-lisp-stream stream)))
  98
  99 (defmethod stream-force-output ((stream character-output-stream))
 100   (force-output (character-output-stream-lisp-stream stream)))
 101
 102 (defmethod stream-clear-output ((stream character-output-stream))
 103   (clear-output (character-output-stream-lisp-stream stream)))
 104
 105 (defmethod stream-file-position ((stream character-output-stream) &optional new-value)
 106   (if new-value
 107       (setf (character-output-stream-position stream) new-value)
 108       (character-output-stream-position stream)))
 109 \f
 110 ;;;; example character input stream encapsulating a lisp-stream
 111
 112 (defun make-character-input-stream (lisp-stream)
 113   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 114
 115 (defmethod open-stream-p ((stream character-input-stream))
 116   (open-stream-p (character-input-stream-lisp-stream stream)))
 117
 118 (defmethod close ((stream character-input-stream) &key abort)
 119   (close (character-input-stream-lisp-stream stream) :abort abort))
 120
 121 (defmethod input-stream-p ((stream character-input-stream))
 122   (input-stream-p (character-input-stream-lisp-stream stream)))
 123
 124 (defmethod output-stream-p ((stream character-input-stream))
 125   (output-stream-p (character-input-stream-lisp-stream stream)))
 126
 127 (defmethod stream-read-char ((stream character-input-stream))
 128   (read-char (character-input-stream-lisp-stream stream) nil :eof))
 129
 130 (defmethod stream-unread-char ((stream character-input-stream) character)
 131   (unread-char character (character-input-stream-lisp-stream stream)))
 132
 133 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 134   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 135
 136 (defmethod stream-clear-input ((stream character-input-stream))
 137   (clear-input (character-input-stream-lisp-stream stream)))
 138 \f
 139 ;;;; tests for character i/o, using the above:
 140
 141 (let ((test-string (format nil
 142                            "~% This is a test.~& This is the second line.~
 143                              ~% This should be the third and last line.~%")))
 144   (with-input-from-string (foo test-string)
 145     (assert (equal
 146              (with-output-to-string (bar)
 147                (let ((our-char-input (make-character-input-stream foo))
 148                      (our-char-output (make-character-output-stream bar)))
 149                  (assert (open-stream-p our-char-input))
 150                  (assert (open-stream-p our-char-output))
 151                  (assert (input-stream-p our-char-input))
 152                  (assert (output-stream-p our-char-output))
 153                  (let ((test-char (read-char our-char-input)))
 154                    (assert (char-equal test-char (char test-string 0)))
 155                    (unread-char test-char our-char-input))
 156                  (do ((line #1=(read-line our-char-input nil nil nil) #1#))
 157                      ((not (listen our-char-input))
 158                       (format our-char-output "~A~%" line))
 159                    (format our-char-output "~A~%" line))
 160                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 161              test-string))))
 162
 163 (assert
 164   (equal
 165    (with-output-to-string (foo)
 166      (let ((our-char-output (make-character-output-stream foo)))
 167        (write-char #\a our-char-output)
 168        (finish-output our-char-output)
 169        (write-char #\  our-char-output)
 170        (force-output our-char-output)
 171        (fresh-line our-char-output)
 172        (write-char #\b our-char-output)
 173        (clear-output our-char-output)
 174        (terpri our-char-output)
 175        (assert (null (fresh-line our-char-output)))
 176        (write-char #\c our-char-output)))
 177    (format nil "a ~%b~%c")))
 178
 179 ;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic
 180 ;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some
 181 ;;; cases. Try to verify that we don't end up doing tests like that on
 182 ;;; bare Gray streams and thus bogusly omitting pretty-printing
 183 ;;; operations.
 184 (flet ((frob ()
 185          (with-output-to-string (string)
 186            (let ((gray-output-stream (make-character-output-stream string)))
 187              (format gray-output-stream
 188                      "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
 189   (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
 190   (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
 191
 192 ;;; tests for STREAM-READ-SEQUENCE/STREAM-WRITE-SEQUENCE for
 193 ;;; subclasses of FUNDAMENTAL-CHARACTER-INPUT-/OUTPUT-STREAM (i.e.,
 194 ;;; where the default methods are available)
 195 (let* ((test-string (format nil
 196                             "~% Testing for STREAM-*-SEQUENCE.~
 197                              ~& This is the second line.~
 198                              ~% This should be the third and last line.~%"))
 199        (test-string-len (length test-string))
 200        (output-test-string (make-string test-string-len)))
 201   ;; test for READ-/WRITE-SEQUENCE on strings/vectors
 202   (with-input-from-string (foo test-string)
 203     (assert (equal
 204              (with-output-to-string (bar)
 205                (let ((our-char-input (make-character-input-stream foo))
 206                      (our-char-output (make-character-output-stream bar)))
 207                  (read-sequence output-test-string our-char-input)
 208                  (assert (typep output-test-string 'string))
 209                  (write-sequence output-test-string our-char-output)
 210                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 211              test-string)))
 212   ;; test for READ-/WRITE-SEQUENCE on lists
 213   (let ((output-test-list (make-list test-string-len)))
 214     (with-input-from-string (foo test-string)
 215       (assert (equal
 216              (with-output-to-string (bar)
 217                (let ((our-char-input (make-character-input-stream foo))
 218                      (our-char-output (make-character-output-stream bar)))
 219                  (read-sequence output-test-list our-char-input)
 220                  (assert (typep output-test-list 'list))
 221                  (write-sequence output-test-list our-char-output)
 222                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 223              test-string)))))
 224 \f
 225 ;;;; example classes for binary output
 226
 227 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
 228   ((lisp-stream :initarg :lisp-stream
 229                 :accessor binary-to-char-output-stream-lisp-stream)))
 230
 231 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
 232   ((lisp-stream :initarg :lisp-stream
 233                 :accessor binary-to-char-input-stream-lisp-stream)))
 234
 235 (defmethod stream-element-type ((stream binary-to-char-output-stream))
 236   '(unsigned-byte 8))
 237 (defmethod stream-element-type ((stream binary-to-char-input-stream))
 238   '(unsigned-byte 8))
 239
 240 (defun make-binary-to-char-input-stream (lisp-stream)
 241   (make-instance 'binary-to-char-input-stream
 242                  :lisp-stream lisp-stream))
 243
 244 (defun make-binary-to-char-output-stream (lisp-stream)
 245   (make-instance 'binary-to-char-output-stream
 246                  :lisp-stream lisp-stream))
 247
 248 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
 249   (let ((char (read-char
 250                (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
 251     (if (eq char :eof)
 252         char
 253         (char-code char))))
 254
 255 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
 256   (let ((char (code-char integer)))
 257     (write-char char
 258                 (binary-to-char-output-stream-lisp-stream stream))))
 259 \f
 260 ;;;; tests using binary i/o, using the above
 261
 262 (let ((test-string (format nil
 263                            "~% This is a test.~& This is the second line.~
 264                             ~% This should be the third and last line.~%")))
 265   (with-input-from-string (foo test-string)
 266     (assert (equal
 267              (with-output-to-string (bar)
 268                (let ((our-bin-to-char-input (make-binary-to-char-input-stream
 269                                              foo))
 270                      (our-bin-to-char-output (make-binary-to-char-output-stream
 271                                               bar)))
 272                  (assert (open-stream-p our-bin-to-char-input))
 273                  (assert (open-stream-p our-bin-to-char-output))
 274                  (assert (input-stream-p our-bin-to-char-input))
 275                  (assert (output-stream-p our-bin-to-char-output))
 276                  (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
 277                      ((eq byte :eof))
 278                    (write-byte byte our-bin-to-char-output))))
 279              test-string))))
 280
 281 \f
 282
 283 ;;; Minimal test of file-position
 284 (let ((stream (make-instance 'character-output-stream)))
 285   (assert (= (file-position stream) 42))
 286   (assert (file-position stream 50))
 287   (assert (= (file-position stream) 50)))
 288
 289 ;;; Using gray streams as parts of two-way-, concatenate-, and synonym-streams.
 290
 291 (defvar *gray-binary-data*
 292   (let ((vector (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0)))
 293     (dotimes (i (length vector))
 294       (setf (aref vector i) (random 256)))
 295     vector))
 296
 297 (defun vector-hop-or-eof (vector)
 298   (let ((pos (fill-pointer vector)))
 299     (if (< pos (array-total-size vector))
 300         (prog1
 301             (aref vector pos)
 302           (incf (fill-pointer vector)))
 303         :eof)))
 304
 305 (defclass part-of-composite-stream (fundamental-binary-input-stream)
 306   ())
 307
 308 (defmethod stream-read-byte ((stream part-of-composite-stream))
 309   (vector-hop-or-eof *gray-binary-data*))
 310
 311 (defmethod stream-element-type ((stream part-of-composite-stream))
 312   '(unsigned-byte 8))
 313
 314 (defvar *part-of-composite* (make-instance 'part-of-composite-stream))
 315
 316 (defun test-composite-reads (&rest streams)
 317   (dolist (stream streams)
 318     (setf (fill-pointer *gray-binary-data*) 0)
 319     (let ((binary-buffer (make-array 1024 :element-type '(unsigned-byte 8))))
 320       (assert (eql 1024 (read-sequence binary-buffer stream)))
 321       (dotimes (i 1024)
 322         (unless (eql (aref *gray-binary-data* i)
 323                      (aref binary-buffer i))
 324           (error "wanted ~S at ~S, got ~S (~S)"
 325                  (aref *gray-binary-data* i)
 326                  i
 327                  (aref binary-buffer i)
 328                  stream))))))
 329
 330 (test-composite-reads
 331  (make-two-way-stream *part-of-composite* *standard-output*)
 332  (make-concatenated-stream *part-of-composite*)
 333  (make-synonym-stream '*part-of-composite*))
 334
 335 ;;; Using STREAM-FILE-POSITION on an ANSI-STREAM
 336 (with-output-to-string (s)
 337   (assert (zerop (file-position s)))
 338   (assert (zerop (stream-file-position s))))
 339
 340 (defclass broken-char-input-stream (fundamental-input-stream) ())
 341 (defmethod stream-read-char ((s broken-char-input-stream))
 342   :1potato)
 343 (defmethod stream-read-char-no-hang ((s broken-char-input-stream))
 344   :1potato)
 345 (defmethod stream-peek-char ((s broken-char-input-stream))
 346   :1potato)
 347 (defclass broken-binary-input-stream (fundamental-input-stream) ())
 348 (defmethod stream-read-byte ((s broken-binary-input-stream))
 349   :2potato)
 350
 351 (with-test (:name :read-char/read-byte-check-types)
 352   (loop for (class fn . arg) in '((broken-char-input-stream read-char)
 353                                   (broken-char-input-stream read-char-no-hang)
 354                                   (broken-char-input-stream peek-char #\z)
 355                                   (broken-char-input-stream peek-char t)
 356                                   (broken-char-input-stream peek-char nil)
 357                                   (broken-binary-input-stream read-byte))
 358         for stream = (make-instance class)
 359         do (assert (eq 'type-error
 360                        (handler-case (if arg
 361                                          (funcall fn (car arg) stream)
 362                                          (funcall fn stream))
 363                          (type-error () 'type-error))))))