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