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
  65 (defclass character-input-stream (fundamental-character-input-stream)
  66   ((lisp-stream :initarg :lisp-stream
  67                 :accessor character-input-stream-lisp-stream)))
  68 \f
  69 ;;;; example character output stream encapsulating a lisp-stream
  70
  71 (defun make-character-output-stream (lisp-stream)
  72   (make-instance 'character-output-stream :lisp-stream lisp-stream))
  73
  74 (defmethod open-stream-p ((stream character-output-stream))
  75   (open-stream-p (character-output-stream-lisp-stream stream)))
  76
  77 (defmethod close ((stream character-output-stream) &key abort)
  78   (close (character-output-stream-lisp-stream stream) :abort abort))
  79
  80 (defmethod input-stream-p ((stream character-output-stream))
  81   (input-stream-p (character-output-stream-lisp-stream stream)))
  82
  83 (defmethod output-stream-p ((stream character-output-stream))
  84   (output-stream-p (character-output-stream-lisp-stream stream)))
  85
  86 (defmethod stream-write-char ((stream character-output-stream) character)
  87   (write-char character (character-output-stream-lisp-stream stream)))
  88
  89 (defmethod stream-line-column ((stream character-output-stream))
  90   (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
  91
  92 (defmethod stream-line-length ((stream character-output-stream))
  93   (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
  94
  95 (defmethod stream-finish-output ((stream character-output-stream))
  96   (finish-output (character-output-stream-lisp-stream stream)))
  97
  98 (defmethod stream-force-output ((stream character-output-stream))
  99   (force-output (character-output-stream-lisp-stream stream)))
 100
 101 (defmethod stream-clear-output ((stream character-output-stream))
 102   (clear-output (character-output-stream-lisp-stream stream)))
 103 \f
 104 ;;;; example character input stream encapsulating a lisp-stream
 105
 106 (defun make-character-input-stream (lisp-stream)
 107   (make-instance 'character-input-stream :lisp-stream lisp-stream))
 108
 109 (defmethod open-stream-p ((stream character-input-stream))
 110   (open-stream-p (character-input-stream-lisp-stream stream)))
 111
 112 (defmethod close ((stream character-input-stream) &key abort)
 113   (close (character-input-stream-lisp-stream stream) :abort abort))
 114
 115 (defmethod input-stream-p ((stream character-input-stream))
 116   (input-stream-p (character-input-stream-lisp-stream stream)))
 117
 118 (defmethod output-stream-p ((stream character-input-stream))
 119   (output-stream-p (character-input-stream-lisp-stream stream)))
 120
 121 (defmethod stream-read-char ((stream character-input-stream))
 122   (read-char (character-input-stream-lisp-stream stream) nil :eof))
 123
 124 (defmethod stream-unread-char ((stream character-input-stream) character)
 125   (unread-char character (character-input-stream-lisp-stream stream)))
 126
 127 (defmethod stream-read-char-no-hang ((stream character-input-stream))
 128   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
 129
 130 (defmethod stream-clear-input ((stream character-input-stream))
 131   (clear-input (character-input-stream-lisp-stream stream)))
 132 \f
 133 ;;;; tests for character i/o, using the above:
 134
 135 (let ((test-string (format nil
 136                            "~% This is a test.~& This is the second line.~
 137                              ~% This should be the third and last line.~%")))
 138   (with-input-from-string (foo test-string)
 139     (assert (equal
 140              (with-output-to-string (bar)
 141                (let ((our-char-input (make-character-input-stream foo))
 142                      (our-char-output (make-character-output-stream bar)))
 143                  (assert (open-stream-p our-char-input))
 144                  (assert (open-stream-p our-char-output))
 145                  (assert (input-stream-p our-char-input))
 146                  (assert (output-stream-p our-char-output))
 147                  (let ((test-char (read-char our-char-input)))
 148                    (assert (char-equal test-char (char test-string 0)))
 149                    (unread-char test-char our-char-input))
 150                  (do ((line #1=(read-line our-char-input nil nil nil) #1#))
 151                      ((not (listen our-char-input))
 152                       (format our-char-output "~A~%" line))
 153                    (format our-char-output "~A~%" line))
 154                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 155              test-string))))
 156
 157 (assert
 158   (equal
 159    (with-output-to-string (foo)
 160      (let ((our-char-output (make-character-output-stream foo)))
 161        (write-char #\a our-char-output)
 162        (finish-output our-char-output)
 163        (write-char #\  our-char-output)
 164        (force-output our-char-output)
 165        (fresh-line our-char-output)
 166        (write-char #\b our-char-output)
 167        (clear-output our-char-output)
 168        (terpri our-char-output)
 169        (assert (null (fresh-line our-char-output)))
 170        (write-char #\c our-char-output)))
 171    (format nil "a ~%b~%c")))
 172
 173 ;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic
 174 ;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some
 175 ;;; cases. Try to verify that we don't end up doing tests like that on
 176 ;;; bare Gray streams and thus bogusly omitting pretty-printing
 177 ;;; operations.
 178 (flet ((frob ()
 179          (with-output-to-string (string)
 180            (let ((gray-output-stream (make-character-output-stream string)))
 181              (format gray-output-stream
 182                      "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
 183   (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
 184   (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
 185
 186 ;;; tests for STREAM-READ-SEQUENCE/STREAM-WRITE-SEQUENCE for
 187 ;;; subclasses of FUNDAMENTAL-CHARACTER-INPUT-/OUTPUT-STREAM (i.e.,
 188 ;;; where the default methods are available)
 189 (let* ((test-string (format nil
 190                             "~% Testing for STREAM-*-SEQUENCE.~
 191                              ~& This is the second line.~
 192                              ~% This should be the third and last line.~%"))
 193        (test-string-len (length test-string))
 194        (output-test-string (make-string test-string-len)))
 195   ;; test for READ-/WRITE-SEQUENCE on strings/vectors
 196   (with-input-from-string (foo test-string)
 197     (assert (equal
 198              (with-output-to-string (bar)
 199                (let ((our-char-input (make-character-input-stream foo))
 200                      (our-char-output (make-character-output-stream bar)))
 201                  (read-sequence output-test-string our-char-input)
 202                  (assert (typep output-test-string 'string))
 203                  (write-sequence output-test-string our-char-output)
 204                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 205              test-string)))
 206   ;; test for READ-/WRITE-SEQUENCE on lists
 207   (let ((output-test-list (make-list test-string-len)))
 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-list our-char-input)
 214                  (assert (typep output-test-list 'list))
 215                  (write-sequence output-test-list our-char-output)
 216                  (assert (null (peek-char nil our-char-input nil nil nil)))))
 217              test-string)))))
 218 \f
 219 ;;;; example classes for binary output
 220
 221 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
 222   ((lisp-stream :initarg :lisp-stream
 223                 :accessor binary-to-char-output-stream-lisp-stream)))
 224
 225 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
 226   ((lisp-stream :initarg :lisp-stream
 227                 :accessor binary-to-char-input-stream-lisp-stream)))
 228
 229 (defmethod stream-element-type ((stream binary-to-char-output-stream))
 230   '(unsigned-byte 8))
 231 (defmethod stream-element-type ((stream binary-to-char-input-stream))
 232   '(unsigned-byte 8))
 233
 234 (defun make-binary-to-char-input-stream (lisp-stream)
 235   (make-instance 'binary-to-char-input-stream
 236                  :lisp-stream lisp-stream))
 237
 238 (defun make-binary-to-char-output-stream (lisp-stream)
 239   (make-instance 'binary-to-char-output-stream
 240                  :lisp-stream lisp-stream))
 241
 242 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
 243   (let ((char (read-char
 244                (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
 245     (if (eq char :eof)
 246         char
 247         (char-code char))))
 248
 249 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
 250   (let ((char (code-char integer)))
 251     (write-char char
 252                 (binary-to-char-output-stream-lisp-stream stream))))
 253 \f
 254 ;;;; tests using binary i/o, using the above
 255
 256 (let ((test-string (format nil
 257                            "~% This is a test.~& This is the second line.~
 258                             ~% This should be the third and last line.~%")))
 259   (with-input-from-string (foo test-string)
 260     (assert (equal
 261              (with-output-to-string (bar)
 262                (let ((our-bin-to-char-input (make-binary-to-char-input-stream
 263                                              foo))
 264                      (our-bin-to-char-output (make-binary-to-char-output-stream
 265                                               bar)))
 266                  (assert (open-stream-p our-bin-to-char-input))
 267                  (assert (open-stream-p our-bin-to-char-output))
 268                  (assert (input-stream-p our-bin-to-char-input))
 269                  (assert (output-stream-p our-bin-to-char-output))
 270                  (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
 271                      ((eq byte :eof))
 272                    (write-byte byte our-bin-to-char-output))))
 273              test-string))))
 274 \f
 275 ;;;; Voila!
 276
 277 (quit :unix-status 104) ; success