test.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
test.lisp (41033B)
---
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS-TEST; Base: 10 -*-
2 ;;; $Header: /usr/local/cvsrep/flexi-streams/test/test.lisp,v 1.39 2008/05/30 09:10:55 edi Exp $
3
4 ;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :flexi-streams-test)
31
32 (defmacro with-test-suite ((test-description &key show-progress-p) &body body)
33 "Defines a test suite. Three utilities are available inside of the
34 body of the macro: The function FAIL, and the macros CHECK and
35 WITH-EXPECTED-ERROR. FAIL, the lowest level utility, marks the test
36 defined by WITH-TEST-SUITE as failed. CHECK checks whether its argument is
37 true, otherwise it calls FAIL. If during evaluation of the specified
38 expression any condition is signalled, this is also considered a
39 failure. WITH-EXPECTED-ERROR executes its body and considers the test
40 a success if the specified error was signalled, otherwise it calls
41 FAIL.
42
43 WITH-TEST-SUITE prints a simple progress report if SHOW-PROGRESS-P is true."
44 (with-unique-names (successp testcount)
45 (with-rebinding (show-progress-p)
46 `(let ((,successp t)
47 (,testcount 1))
48 (when (and ,show-progress-p (not (numberp ,show-progress-p)))
49 (setq ,show-progress-p 1))
50 (flet ((fail (format-str &rest format-args)
51 (apply #'format t format-str format-args)
52 (setq ,successp nil))
53 (maybe-show-progress ()
54 (when (and ,show-progress-p (zerop (mod ,testcount ,show-progress-p)))
55 (format t ".")
56 (when (zerop (mod ,testcount (* 10 ,show-progress-p)))
57 (terpri))
58 (force-output))
59 (incf ,testcount)))
60 (macrolet ((check (expression)
61 `(progn
62 (maybe-show-progress)
63 (handler-case
64 (unless ,expression
65 (fail "~&Test ~S failed.~%" ',expression))
66 (error (c)
67 (fail "~&Test ~S failed signalling error of type ~A: ~A.~%"
68 ',expression (type-of c) c)))))
69 (with-expected-error ((condition-type) &body body)
70 `(progn
71 (maybe-show-progress)
72 (handler-case (progn ,@body)
73 (,condition-type () t)
74 (:no-error (&rest args)
75 (declare (ignore args))
76 (fail "~&Expected condition ~S not signalled.~%"
77 ',condition-type))))))
78 (format t "~&Test suite: ~S~%" ,test-description)
79 ,@body))
80 ,successp))))
81
82 ;; LW can't indent this correctly because it's in a MACROLET
83 #+:lispworks
84 (editor:setup-indent "with-expected-error" 1 2 4)
85
86 (defconstant +buffer-size+ 8192
87 "Size of buffers for COPY-STREAM* below.")
88
89 (defvar *copy-function* nil
90 "Which function to use when copying from one stream to the other -
91 see for example COPY-FILE below.")
92
93 (defvar *this-file* (load-time-value
94 (or #.*compile-file-pathname* *load-pathname*))
95 "The pathname of the file \(`test.lisp') where this variable was
96 defined.")
97
98 #+:lispworks
99 (defun get-env-variable-as-directory (name)
100 (lw:when-let (string (lw:environment-variable name))
101 (when (plusp (length string))
102 (cond ((find (char string (1- (length string))) "\\/" :test #'char=) string)
103 (t (lw:string-append string "/"))))))
104
105 (defvar *tmp-dir*
106 (load-time-value
107 (merge-pathnames "odd-streams-test/"
108 #+:allegro (system:temporary-directory)
109 #+:lispworks (pathname (or (get-env-variable-as-directory "TEMP")
110 (get-env-variable-as-directory "TMP")
111 #+:win32 "C:/"
112 #-:win32 "/tmp/"))
113 #-(or :allegro :lispworks) #p"/tmp/"))
114 "The pathname of a temporary directory used for testing.")
115
116 (defvar *test-files*
117 '(("kafka" (:utf8 :latin1 :cp1252))
118 ("tilton" (:utf8 :ascii))
119 ("hebrew" (:utf8 :latin8))
120 ("russian" (:utf8 :koi8r))
121 ("unicode_demo" (:utf8 :ucs2 :ucs4)))
122 "A list of test files where each entry consists of the name
123 prefix and a list of encodings.")
124
125 (defun create-file-variants (file-name symbol)
126 "For a name suffix FILE-NAME and a symbol SYMBOL denoting an
127 encoding returns a list of pairs where the car is a full file
128 name and the cdr is the corresponding external format. This list
129 contains all possible variants w.r.t. to line-end conversion and
130 endianness."
131 (let ((args (ecase symbol
132 (:ascii '(:ascii))
133 (:latin1 '(:latin-1))
134 (:latin8 '(:hebrew))
135 (:cp1252 '(:code-page :id 1252))
136 (:koi8r '(:koi8-r))
137 (:utf8 '(:utf-8))
138 (:ucs2 '(:utf-16))
139 (:ucs4 '(:utf-32))))
140 (endianp (member symbol '(:ucs2 :ucs4))))
141 (loop for little-endian in (if endianp '(t nil) '(t))
142 for endian-suffix in (if endianp '("_le" "_be") '(""))
143 nconc (loop for eol-style in '(:lf :cr :crlf)
144 collect (cons (format nil "~A_~(~A~)_~(~A~)~A.txt"
145 file-name symbol eol-style endian-suffix)
146 (apply #'make-external-format
147 (append args `(:eol-style ,eol-style
148 :little-endian ,little-endian))))))))
149
150 (defun create-test-combinations (file-name symbols &optional simplep)
151 "For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting
152 different encodings of the corresponding file returns a list of lists
153 which can be used as arglists by COMPARE-FILES. If SIMPLEP is true, a
154 list which can be used for the string and sequence tests below is
155 returned."
156 (let ((file-variants (loop for symbol in symbols
157 nconc (create-file-variants file-name symbol))))
158 (loop for (name-in . external-format-in) in file-variants
159 when simplep
160 collect (list name-in external-format-in)
161 else
162 nconc (loop for (name-out . external-format-out) in file-variants
163 collect (list name-in external-format-in name-out external-format-out)))))
164
165 (defun file-equal (file1 file2)
166 "Returns a true value iff FILE1 and FILE2 have the same
167 contents \(viewed as binary files)."
168 (with-open-file (stream1 file1 :element-type 'octet)
169 (with-open-file (stream2 file2 :element-type 'octet)
170 (and (= (file-length stream1) (file-length stream2))
171 (loop for byte1 = (read-byte stream1 nil nil)
172 for byte2 = (read-byte stream2 nil nil)
173 while (and byte1 byte2)
174 always (= byte1 byte2))))))
175
176 (defun copy-stream (stream-in external-format-in stream-out external-format-out)
177 "Copies the contents of the binary stream STREAM-IN to the
178 binary stream STREAM-OUT using flexi streams - STREAM-IN is read
179 with the external format EXTERNAL-FORMAT-IN and STREAM-OUT is
180 written with EXTERNAL-FORMAT-OUT."
181 (let ((in (make-flexi-stream stream-in :external-format external-format-in))
182 (out (make-flexi-stream stream-out :external-format external-format-out)))
183 (loop for line = (read-line in nil nil)
184 while line
185 do (write-line line out))))
186
187 (defun copy-stream* (stream-in external-format-in stream-out external-format-out)
188 "Like COPY-STREAM, but uses READ-SEQUENCE and WRITE-SEQUENCE instead
189 of READ-LINE and WRITE-LINE."
190 (let ((in (make-flexi-stream stream-in :external-format external-format-in))
191 (out (make-flexi-stream stream-out :external-format external-format-out))
192 (buffer (make-array +buffer-size+ :element-type 'char*)))
193 (loop
194 (let ((position (read-sequence buffer in)))
195 (when (zerop position) (return))
196 (write-sequence buffer out :end position)))))
197
198 (defun copy-file (path-in external-format-in path-out external-format-out direction-out direction-in)
199 "Copies the contents of the file denoted by the pathname
200 PATH-IN to the file denoted by the pathname PATH-OUT using flexi
201 streams - STREAM-IN is read with the external format
202 EXTERNAL-FORMAT-IN and STREAM-OUT is written with
203 EXTERNAL-FORMAT-OUT. The input file is opened with
204 the :DIRECTION keyword argument DIRECTION-IN, the output file is
205 opened with the :DIRECTION keyword argument DIRECTION-OUT."
206 (with-open-file (in path-in
207 :element-type 'octet
208 :direction direction-in
209 :if-does-not-exist :error
210 :if-exists :overwrite)
211 (with-open-file (out path-out
212 :element-type 'octet
213 :direction direction-out
214 :if-does-not-exist :create
215 :if-exists :supersede)
216 (funcall *copy-function* in external-format-in out external-format-out))))
217
218 #+:lispworks
219 (defun copy-file-lw (path-in external-format-in path-out external-format-out direction-out direction-in)
220 "Same as COPY-FILE, but uses character streams instead of
221 binary streams. Only used to test LispWorks-specific behaviour."
222 (with-open-file (in path-in
223 :external-format '(:latin-1 :eol-style :lf)
224 :element-type 'base-char
225 :direction direction-in
226 :if-does-not-exist :error
227 :if-exists :overwrite)
228 (with-open-file (out path-out
229 :external-format '(:latin-1 :eol-style :lf)
230 :element-type 'base-char
231 :direction direction-out
232 :direction :output
233 :if-does-not-exist :create
234 :if-exists :supersede)
235 (funcall *copy-function* in external-format-in out external-format-out))))
236
237 (defun compare-files (&key verbose)
238 "Each test in this suite copies the contents of one file \(in the
239 `test' directory) to another file \(in a temporary directory) using
240 flexi streams with different external formats. The resulting file is
241 compared with an existing file in the `test' directory to check if the
242 outcome is as expected. Uses various variants of the :DIRECTION
243 keyword when opening the files.
244
245 Returns a true value iff all tests succeeded. Prints information
246 about each individual comparison if VERBOSE is true."
247 (with-test-suite ("Reading/writing files" :show-progress-p (not verbose))
248 (flet ((one-comparison (path-in external-format-in path-out external-format-out verbose)
249 (when verbose
250 (format t "~&File ~S, using copy function ~S" (file-namestring path-in) *copy-function*)
251 (format t "~& and external formats ~S --> ~S"
252 (normalize-external-format external-format-in)
253 (normalize-external-format external-format-out)))
254 (let ((full-path-in (merge-pathnames path-in *this-file*))
255 (full-path-out (ensure-directories-exist
256 (merge-pathnames path-out *tmp-dir*)))
257 (full-path-orig (merge-pathnames path-out *this-file*)))
258 (dolist (direction-out '(:output :io))
259 (dolist (direction-in '(:input :io))
260 (when verbose
261 (format t "~&...directions ~S --> ~S" direction-in direction-out))
262 (copy-file full-path-in external-format-in
263 full-path-out external-format-out
264 direction-out direction-in)
265 (check (file-equal full-path-out full-path-orig))
266 #+:lispworks
267 (progn
268 (when verbose
269 (format t "~&...directions ~S --> ~S \(LispWorks)" direction-in direction-out))
270 (copy-file-lw full-path-in external-format-in
271 full-path-out external-format-out
272 direction-out direction-in)
273 (check (file-equal full-path-out full-path-orig))))))))
274 (loop with compare-files-args-list = (loop for (file-name symbols) in *test-files*
275 nconc (create-test-combinations file-name symbols))
276 for *copy-function* in '(copy-stream copy-stream*)
277 do (loop for (path-in external-format-in path-out external-format-out) in compare-files-args-list
278 do (one-comparison path-in external-format-in path-out external-format-out verbose))))))
279
280 (defun file-as-octet-vector (pathspec)
281 "Returns the contents of the file denoted by PATHSPEC as a vector of
282 octets."
283 (with-open-file (in pathspec :element-type 'octet)
284 (let ((vector (make-array (file-length in) :element-type 'octet)))
285 (read-sequence vector in)
286 vector)))
287
288 (defun file-as-string (pathspec external-format)
289 "Reads the contents of the file denoted by PATHSPEC using the
290 external format EXTERNAL-FORMAT and returns the result as a string."
291 (with-open-file (in pathspec :element-type 'octet)
292 (let* ((number-of-octets (file-length in))
293 (in (make-flexi-stream in :external-format external-format))
294 (string (make-array number-of-octets
295 :element-type #+:lispworks 'lw:simple-char
296 #-:lispworks 'character
297 :fill-pointer t)))
298 (setf (fill-pointer string) (read-sequence string in))
299 string)))
300
301 (defun old-string-to-octets (string &key
302 (external-format (make-external-format :latin1))
303 (start 0) end)
304 "The old version of STRING-TO-OCTETS. We can use it to test
305 in-memory streams."
306 (declare (optimize speed))
307 (with-output-to-sequence (out)
308 (let ((flexi (make-flexi-stream out :external-format external-format)))
309 (write-string string flexi :start start :end end))))
310
311 (defun old-octets-to-string (vector &key
312 (external-format (make-external-format :latin1))
313 (start 0) (end (length vector)))
314 "The old version of OCTETS-TO-STRING. We can use it to test
315 in-memory streams."
316 (declare (optimize speed))
317 (with-input-from-sequence (in vector :start start :end end)
318 (let ((flexi (make-flexi-stream in :external-format external-format))
319 (result (make-array (- end start)
320 :element-type #+:lispworks 'lw:simple-char
321 #-:lispworks 'character
322 :fill-pointer t)))
323 (setf (fill-pointer result)
324 (read-sequence result flexi))
325 result)))
326
327 (defun string-tests (&key verbose)
328 "Tests whether conversion from strings to octets and vice versa
329 works as expected. Also tests with the old versions of the conversion
330 functions in order to test in-memory streams."
331 (with-test-suite ("String tests" :show-progress-p (and (not verbose) 10))
332 (flet ((one-string-test (pathspec external-format verbose)
333 (when verbose
334 (format t "~&With external format ~S:" (normalize-external-format external-format)))
335 (let* ((full-path (merge-pathnames pathspec *this-file*))
336 (octets-vector (file-as-octet-vector full-path))
337 (octets-list (coerce octets-vector 'list))
338 (string (file-as-string full-path external-format)))
339 (when verbose
340 (format t "~&...testing OCTETS-TO-STRING"))
341 (check (string= (octets-to-string octets-vector :external-format external-format) string))
342 (check (string= (octets-to-string octets-list :external-format external-format) string))
343 (when verbose
344 (format t "~&...testing STRING-TO-OCTETS"))
345 (check (equalp (string-to-octets string :external-format external-format) octets-vector))
346 (when verbose
347 (format t "~&...testing in-memory streams"))
348 (check (string= (old-octets-to-string octets-vector :external-format external-format) string))
349 (check (string= (old-octets-to-string octets-list :external-format external-format) string))
350 (check (equalp (old-string-to-octets string :external-format external-format) octets-vector)))))
351 (loop with simple-test-args-list = (loop for (file-name symbols) in *test-files*
352 nconc (create-test-combinations file-name symbols t))
353 for (pathspec external-format) in simple-test-args-list
354 do (one-string-test pathspec external-format verbose)))))
355
356
357 (defun sequence-equal (seq1 seq2)
358 "Whether the two sequences have the same elements."
359 (and (= (length seq1) (length seq2))
360 (loop for i below (length seq1)
361 always (eql (elt seq1 i) (elt seq2 i)))))
362
363 (defun sequence-tests (&key verbose)
364 "Several tests to confirm that READ-SEQUENCE and WRITE-SEQUENCE
365 behave as expected."
366 (with-test-suite ("Sequence tests" :show-progress-p (and (not verbose) 10))
367 (flet ((one-sequence-test (pathspec external-format verbose)
368 (when verbose
369 (format t "~&With external format ~S:" (normalize-external-format external-format)))
370 (let* ((full-path (merge-pathnames pathspec *this-file*))
371 (file-string (file-as-string full-path external-format))
372 (string-length (length file-string))
373 (octets (file-as-octet-vector full-path))
374 (octet-length (length octets)))
375 (when (external-format-equal external-format (make-external-format :utf8))
376 (when verbose
377 (format t "~&...reading octets"))
378 (with-open-file (in full-path :element-type 'octet)
379 (let* ((in (make-flexi-stream in :external-format external-format))
380 (list (make-list octet-length)))
381 (setf (flexi-stream-element-type in) 'octet)
382 (let ((position #-:clisp
383 (read-sequence list in)
384 #+:clisp
385 (ext:read-byte-sequence list in)))
386 (check (= position
387 (flexi-stream-position in))))
388 (check (sequence-equal list octets))))
389 (with-open-file (in full-path :element-type 'octet)
390 (let* ((in (make-flexi-stream in :external-format external-format))
391 (third (floor octet-length 3))
392 (half (floor octet-length 2))
393 (vector (make-array half :element-type 'octet)))
394 (check (sequence-equal (loop repeat third
395 collect (read-byte in))
396 (subseq octets 0 third)))
397 (read-sequence vector in)
398 (check (sequence-equal vector (subseq octets third (+ third half)))))))
399 (when verbose
400 (format t "~&...reading characters"))
401 (with-open-file (in full-path :element-type 'octet)
402 (let* ((in (make-flexi-stream in :external-format external-format))
403 (string (make-string (- string-length 10) :element-type 'char*)))
404 (setf (flexi-stream-element-type in) 'octet)
405 (check (sequence-equal (loop repeat 10
406 collect (read-char in))
407 (subseq file-string 0 10)))
408 (read-sequence string in)
409 (check (sequence-equal string (subseq file-string 10)))))
410 (with-open-file (in full-path :element-type 'octet)
411 (let* ((in (make-flexi-stream in :external-format external-format))
412 (list (make-list (- string-length 100))))
413 (check (sequence-equal (loop repeat 50
414 collect (read-char in))
415 (subseq file-string 0 50)))
416 #-:clisp
417 (read-sequence list in)
418 #+:clisp
419 (ext:read-char-sequence list in)
420 (check (sequence-equal list (subseq file-string 50 (- string-length 50))))
421 (check (sequence-equal (loop repeat 50
422 collect (read-char in))
423 (subseq file-string (- string-length 50))))))
424 (with-open-file (in full-path :element-type 'octet)
425 (let* ((in (make-flexi-stream in :external-format external-format))
426 (array (make-array (- string-length 50))))
427 (check (sequence-equal (loop repeat 25
428 collect (read-char in))
429 (subseq file-string 0 25)))
430 #-:clisp
431 (read-sequence array in)
432 #+:clisp
433 (ext:read-char-sequence array in)
434 (check (sequence-equal array (subseq file-string 25 (- string-length 25))))
435 (check (sequence-equal (loop repeat 25
436 collect (read-char in))
437 (subseq file-string (- string-length 25))))))
438 (let ((path-out (ensure-directories-exist (merge-pathnames pathspec *tmp-dir*))))
439 (when verbose
440 (format t "~&...writing sequences"))
441 (with-open-file (out path-out
442 :direction :output
443 :if-exists :supersede
444 :element-type 'octet)
445 (let ((out (make-flexi-stream out :external-format external-format)))
446 (write-sequence octets out)))
447 (check (file-equal full-path path-out))
448 (with-open-file (out path-out
449 :direction :output
450 :if-exists :supersede
451 :element-type 'octet)
452 (let ((out (make-flexi-stream out :external-format external-format)))
453 (write-sequence file-string out)))
454 (check (file-equal full-path path-out))
455 (with-open-file (out path-out
456 :direction :output
457 :if-exists :supersede
458 :element-type 'octet)
459 (let ((out (make-flexi-stream out :external-format external-format)))
460 (write-sequence file-string out :end 100)
461 (write-sequence octets out
462 :start (length (string-to-octets file-string
463 :external-format external-format
464 :end 100)))))
465 (check (file-equal full-path path-out))))))
466
467 (loop with simple-test-args-list = (loop for (file-name symbols) in *test-files*
468 nconc (create-test-combinations file-name symbols t))
469 for (pathspec external-format) in simple-test-args-list
470 do (one-sequence-test pathspec external-format verbose)))))
471
472 (defmacro using-values ((&rest values) &body body)
473 "Executes BODY and feeds an element from VALUES to the USE-VALUE
474 restart each time a EXTERNAL-FORMAT-ENCODING-ERROR is signalled.
475 Signals an error when there are more or less
476 EXTERNAL-FORMAT-ENCODING-ERRORs than there are elements in VALUES."
477 (with-unique-names (value-stack condition-counter)
478 `(let ((,value-stack ',values)
479 (,condition-counter 0))
480 (handler-bind ((external-format-encoding-error
481 #'(lambda (c)
482 (declare (ignore c))
483 (unless ,value-stack
484 (error "Too many encoding errors signalled, expected only ~A."
485 ,(length values)))
486 (incf ,condition-counter)
487 (use-value (pop ,value-stack)))))
488 (prog1 (progn ,@body)
489 (when ,value-stack
490 (error "~A encoding errors signalled, but ~A were expected."
491 ,condition-counter ,(length values))))))))
492
493 (defun accept-overlong (octets code-point)
494 "Converts the `overlong' UTF-8 sequence OCTETS to using
495 OCTETS-TO-STRINGS, accepts the expected error with the corresponding
496 restart and checks that the result is CODE-POINT."
497 (handler-bind ((external-format-encoding-error
498 (lambda (c)
499 (declare (ignore c))
500 (invoke-restart 'accept-overlong-sequence))))
501 (string= (octets-to-string octets :external-format :utf-8)
502 (string (code-char code-point)))))
503
504 (defun read-flexi-line (sequence external-format)
505 "Creates and returns a string from the octet sequence SEQUENCE using
506 the external format EXTERNAL-FORMAT."
507 (with-input-from-sequence (in sequence)
508 (setq in (make-flexi-stream in :external-format external-format))
509 (read-line in)))
510
511 (defun read-flexi-line* (sequence external-format)
512 "Like READ-FLEXI-LINE but uses OCTETS-TO-STRING internally."
513 (octets-to-string sequence :external-format external-format))
514
515 (defun error-handling-tests (&key verbose)
516 "Tests several possible errors and how they are handled."
517 (with-test-suite ("Testing error handling" :show-progress-p (not verbose))
518 (macrolet ((want-encoding-error (input format)
519 `(with-expected-error (external-format-encoding-error)
520 (read-flexi-line* ,input ,format))))
521 (when verbose
522 (format t "~&\"Overlong\" UTF-8 sequences"))
523 (want-encoding-error #(#b11000000 #b10000000) :utf-8)
524 (want-encoding-error #(#b11000001 #b10000000) :utf-8)
525 (want-encoding-error #(#b11100000 #b10011111 #b10000000) :utf-8)
526 (want-encoding-error #(#b11110000 #b10001111 #b10000000 #b10000000) :utf-8)
527 (check (accept-overlong #(#b11000000 #b10000000) #b00000000))
528 (check (accept-overlong #(#b11000001 #b10000000) #b01000000))
529 (check (accept-overlong #(#b11100000 #b10011111 #b10000000) #b011111000000))
530 (check (accept-overlong #(#b11110000 #b10001111 #b10000000 #b10000000)
531 #b1111000000000000))
532 (when verbose
533 (format t "~&Invalid lead octets in UTF-8"))
534 (want-encoding-error #(#b11111000) :utf-8)
535 (want-encoding-error #(#b11111001) :utf-8)
536 (want-encoding-error #(#b11111100) :utf-8)
537 (want-encoding-error #(#b11111101) :utf-8)
538 (want-encoding-error #(#b11111110) :utf-8)
539 (want-encoding-error #(#b11111111) :utf-8)
540 (when verbose
541 (format t "~&Illegal code points"))
542 (want-encoding-error #(#x00 #x00 #x11 #x00) :utf-32le)
543 (want-encoding-error #(#x00 #xd8) :utf-16le)
544 (want-encoding-error #(#xff #xdf) :utf-16le))
545 (macrolet ((want-encoding-error (input format)
546 `(with-expected-error (external-format-encoding-error)
547 (read-flexi-line* ,input ,format))))
548 (when verbose
549 (format t "~&UTF-8 sequences which are too short"))
550 (want-encoding-error #(#xe4 #xf6 #xfc) :utf8)
551 (want-encoding-error #(#xc0) :utf8)
552 (want-encoding-error #(#xe0 #xff) :utf8)
553 (want-encoding-error #(#xf0 #xff #xff) :utf8)
554 (when verbose
555 (format t "~&UTF-16 sequences with an odd number of octets"))
556 (want-encoding-error #(#x01) :utf-16le)
557 (want-encoding-error #(#x01 #x01 #x01) :utf-16le)
558 (want-encoding-error #(#x01) :utf-16be)
559 (want-encoding-error #(#x01 #x01 #x01) :utf-16be)
560 (when verbose
561 (format t "~&Missing words in UTF-16"))
562 (want-encoding-error #(#x01 #xd8) :utf-16le)
563 (want-encoding-error #(#xd8 #x01) :utf-16be)
564 (when verbose
565 (format t "~&Missing octets in UTF-32"))
566 (want-encoding-error #(#x01) :utf-32le)
567 (want-encoding-error #(#x01 #x01) :utf-32le)
568 (want-encoding-error #(#x01 #x01 #x01) :utf-32le)
569 (want-encoding-error #(#x01 #x01 #x01 #x01 #x01) :utf-32le)
570 (want-encoding-error #(#x01) :utf-32be)
571 (want-encoding-error #(#x01 #x01) :utf-32be)
572 (want-encoding-error #(#x01 #x01 #x01) :utf-32be)
573 (want-encoding-error #(#x01 #x01 #x01 #x01 #x01) :utf-32be))
574 (when verbose
575 (format t "~&Handling of EOF in the middle of CRLF"))
576 (check (string= #.(string #\Return)
577 (read-flexi-line `(,(char-code #\Return)) '(:ascii :eol-style :crlf))))
578 (let ((*substitution-char* #\?))
579 (when verbose
580 (format t "~&Fixed substitution character #\?")
581 (format t "~&:ASCII doesn't have characters with char codes > 127"))
582 (check (string= "a??" (read-flexi-line `(,(char-code #\a) 128 200) :ascii)))
583 (check (string= "a??" (read-flexi-line* `#(,(char-code #\a) 128 200) :ascii)))
584 (when verbose
585 (format t "~&:WINDOWS-1253 doesn't have a characters with codes 170 and 210"))
586 (check (string= "a??" (read-flexi-line `(,(char-code #\a) 170 210) :windows-1253)))
587 (check (string= "a??" (read-flexi-line* `#(,(char-code #\a) 170 210) :windows-1253)))
588 (when verbose
589 (format t "~&Not a valid UTF-8 sequence"))
590 (check (string= "??" (read-flexi-line '(#xe4 #xf6 #xfc) :utf8))))
591 (let ((*substitution-char* nil))
592 (when verbose
593 (format t "~&Variable substitution using USE-VALUE restart")
594 (format t "~&:ASCII doesn't have characters with char codes > 127"))
595 (check (string= "abc" (using-values (#\b #\c)
596 (read-flexi-line `(,(char-code #\a) 128 200) :ascii))))
597 (check (string= "abc" (using-values (#\b #\c)
598 (read-flexi-line* `#(,(char-code #\a) 128 200) :ascii))))
599 (when verbose
600 (format t "~&:WINDOWS-1253 doesn't have a characters with codes 170 and 210"))
601 (check (string= "axy" (using-values (#\x #\y)
602 (read-flexi-line `(,(char-code #\a) 170 210) :windows-1253))))
603 (check (string= "axy" (using-values (#\x #\y)
604 (read-flexi-line* `#(,(char-code #\a) 170 210) :windows-1253))))
605 (when verbose
606 (format t "~&Not a valid UTF-8 sequence"))
607 (check (string= "QW" (using-values (#\Q #\W) (read-flexi-line '(#xe4 #xf6 #xfc) :utf8))))
608 (when verbose
609 (format t "~&UTF-8 can't start neither with #b11111110 nor with #b11111111"))
610 (check (string= "QW" (using-values (#\Q #\W) (read-flexi-line '(#b11111110 #b11111111) :utf8))))
611 (when verbose
612 (format t "~&Only one octet in UTF-16 sequence"))
613 (check (string= "E" (using-values (#\E) (read-flexi-line '(#x01) :utf-16le))))
614 (when verbose
615 (format t "~&Two octets in UTF-16, but value of resulting word suggests that another word follows"))
616 (check (string= "R" (using-values (#\R) (read-flexi-line '(#x01 #xd8) :utf-16le))))
617 (when verbose
618 (format t "~&The second word must fit into the [#xdc00; #xdfff] interval, but it is #xdbff"))
619 (check (string= "T" (using-values (#\T) (read-flexi-line '(#x01 #xd8 #xff #xdb) :utf-16le))))
620 (check (string= "T" (using-values (#\T) (read-flexi-line* #(#x01 #xd8 #xff #xdb) :utf-16le))))
621 (when verbose
622 (format t "~&The same as for little endian above, but using inverse order of bytes in words"))
623 (check (string= "E" (using-values (#\E) (read-flexi-line '(#x01) :utf-16be))))
624 (check (string= "R" (using-values (#\R) (read-flexi-line '(#xd8 #x01) :utf-16be))))
625 (check (string= "T" (using-values (#\T) (read-flexi-line '(#xd8 #x01 #xdb #xff) :utf-16be))))
626 (check (string= "T" (using-values (#\T) (read-flexi-line* #(#xd8 #x01 #xdb #xff) :utf-16be))))
627 (when verbose
628 (format t "~&EOF in the middle of a 4-octet sequence in UTF-32"))
629 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01) :utf-32le))))
630 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01) :utf-32le))))
631 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01 #x01) :utf-32le))))
632 (check (string= "aY" (using-values (#\Y)
633 (read-flexi-line `(,(char-code #\a) #x00 #x00 #x00 #x01) :utf-32le))))
634 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01) :utf-32be))))
635 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01) :utf-32be))))
636 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x01 #x01) :utf-32be))))
637 (check (string= "aY" (using-values (#\Y)
638 (read-flexi-line `(#x00 #x00 #x00 ,(char-code #\a) #x01) :utf-32be)))))))
639
640 (defun unread-char-tests (&key verbose)
641 "Tests whether UNREAD-CHAR behaves as expected."
642 (with-test-suite ("UNREAD-CHAR behaviour." :show-progress-p (and (not verbose) 100))
643 (flet ((test-one-file (file-name external-format)
644 (when verbose
645 (format t "~& ...and external format ~A" (normalize-external-format external-format)))
646 (with-open-file (in (merge-pathnames file-name *this-file*)
647 :element-type 'flex:octet)
648 (let ((in (make-flexi-stream in :external-format external-format)))
649 (loop repeat 300
650 for char = (read-char in)
651 do (unread-char char in)
652 (check (char= (read-char in) char)))))))
653 (loop for (file-name symbols) in *test-files*
654 when verbose
655 do (format t "~&With file ~S" file-name)
656 do (loop for symbol in symbols
657 do (loop for (file-name . external-format) in (create-file-variants file-name symbol)
658 do (test-one-file file-name external-format)))))))
659
660 (defun column-tests (&key verbose)
661 (with-test-suite ("STREAM-LINE-COLUMN tests" :show-progress-p (not verbose))
662 (let* ((binary-stream (flexi-streams:make-in-memory-output-stream))
663 (stream (flexi-streams:make-flexi-stream binary-stream :external-format :iso-8859-1)))
664 (write-sequence "hello" stream)
665 (format stream "~12Tworld")
666 (finish-output stream)
667 (check (string= "hello world"
668 (flexi-streams:octets-to-string
669 (flexi-streams::vector-stream-vector binary-stream)
670 :external-format :iso-8859-1)))
671 (terpri stream)
672 (check (= 0 (flexi-stream-column stream)))
673 (write-sequence "abc" stream)
674 (check (= 3 (flexi-stream-column stream)))
675 (terpri stream)
676 (check (= 0 (flexi-stream-column stream))))))
677
678 (defun make-external-format-tests (&key verbose)
679 (with-test-suite ("MAKE-EXTERNAL-FORMAT tests" :show-progress-p (not verbose))
680 (flet ((make-case (real-name &key id name)
681 (list real-name
682 :id id
683 :input-names (list name (string-upcase name) (string-downcase name)))))
684 (let ((cases (append '((:utf-8 :id nil
685 :input-names (:utf8 :utf-8 "utf8" "utf-8" "UTF8" "UTF-8")))
686 (loop for (name . real-name) in +name-map+
687 unless (member :code-page (list name real-name))
688 append (list (make-case real-name :name name)
689 (make-case real-name :name real-name)))
690 (loop for (name . definition) in +shortcut-map+
691 for key = (car definition)
692 for id = (getf (cdr definition) :id)
693 for expected = (or (cdr (assoc key +name-map+)) key)
694 collect (make-case expected :id id :name name)))))
695
696 (loop for (expected-name . kwargs) in cases
697 for id = (getf kwargs :id)
698 for input-names = (getf kwargs :input-names)
699 do (loop for name in input-names
700 for ext-format = (make-external-format name)
701 do (check (eq (flex:external-format-name ext-format) expected-name))
702 when id
703 do (check (= (flex:external-format-id ext-format) id))))))
704
705 (let ((error-cases '("utf-8 " " utf-8" "utf8 " " utf8" "utf89" :utf89 utf89 :code-page nil)))
706 (loop for input-name in error-cases
707 do (with-expected-error (external-format-error)
708 (make-external-format input-name))))))
709
710 (defun peek-byte-tests (&key verbose)
711 (with-test-suite ("PEEK-BYTE tests" :show-progress-p (not verbose))
712 (flex:with-input-from-sequence (input #(0 1 2))
713 (let ((stream (flex:make-flexi-stream input)))
714 ;; If peek-type was specified as 2 we need to peek the first octect equal to 2
715 (check (= 2 (flex::peek-byte stream 2 nil 1)))
716 ;; also, the octet should be unread to the stream so that we can peek it again
717 (check (= 2 (flex::peek-byte stream nil nil nil)))))))
718
719 (defun in-memory-stream-tests (&key verbose)
720 (with-test-suite ("IN-MEMORY-STREAM tests" :show-progress-p (not verbose))
721 (let ((z (make-array 4)))
722 (read-sequence z (make-in-memory-input-stream #(1 2 3 4)))
723 (check (equalp z #(1 2 3 4)))
724 (read-sequence z (make-in-memory-input-stream '(4 3 2 1)))
725 (check (equalp z #(4 3 2 1)))
726 (read-sequence z (make-in-memory-input-stream #(1 2 3 4) :transformer #'1+))
727 (check (equalp z #(2 3 4 5)))
728 (read-sequence z (make-in-memory-input-stream '(1 2 3 4) :transformer #'1-))
729 (check (equalp z #(0 1 2 3))))))
730
731 (defun run-all-tests (&key verbose)
732 "Runs all tests for FLEXI-STREAMS and returns a true value iff all
733 tests succeeded. VERBOSE is interpreted by the individual test suites
734 above."
735 (let ((successp t))
736 (macrolet ((run-test-suite (&body body)
737 `(unless (progn ,@body)
738 (setq successp nil))))
739 (run-test-suite (compare-files :verbose verbose))
740 (run-test-suite (string-tests :verbose verbose))
741 (run-test-suite (sequence-tests :verbose verbose))
742 (run-test-suite (error-handling-tests :verbose verbose))
743 (run-test-suite (unread-char-tests :verbose verbose))
744 (run-test-suite (column-tests :verbose verbose))
745 (run-test-suite (make-external-format-tests :verbose verbose))
746 (run-test-suite (peek-byte-tests :verbose verbose))
747 (run-test-suite (in-memory-stream-tests :verbose verbose))
748 (format t "~2&~:[Some tests failed~;All tests passed~]." successp)
749 successp)))