GopherProxy

	ttest.lisp - clic - Clic is an command line interactive client for gopher writt…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	ttest.lisp (40350B)
	---
	1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS-TEST; Ba…
	2 ;;; $Header: /usr/local/cvsrep/flexi-streams/test/test.lisp,v 1.39 2008/…
	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…
	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…
	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 tr…
	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 ,sh…
	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.~%" ',expressio…
	66 (error (c)
	67 (fail "~&Test ~S failed signalling error …
	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 signal…
	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…
	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-dir…
	110 (get-env-variable-as-dir…
	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 e…
	146 (apply #'make-external-format
	147 (append args `(:eol-style ,eo…
	148 :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 symbo…
	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-varia…
	163 collect (list name-in external-format-in name-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-for…
	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-forma…
	182 (out (make-flexi-stream stream-out :external-format external-for…
	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-fo…
	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-forma…
	191 (out (make-flexi-stream stream-out :external-format external-for…
	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-ou…
	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…
	217
	218 #+:lispworks
	219 (defun copy-file-lw (path-in external-format-in path-out external-format…
	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…
	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 verbos…
	248 (flet ((one-comparison (path-in external-format-in path-out external…
	249 (when verbose
	250 (format t "~&File ~S, using copy function ~S" (file-names…
	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 …
	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)" …
	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)…
	275 nconc (create-test-comb…
	276 for copy-function in '(copy-stream copy-stream*)
	277 do (loop for (path-in external-format-in path-out external-f…
	278 do (one-comparison path-in external-format-in path-…
	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-form…
	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-form…
	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) 1…
	332 (flet ((one-string-test (pathspec external-format verbose)
	333 (when verbose
	334 (format t "~&With external format ~S:" (normalize-externa…
	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…
	342 (check (string= (octets-to-string octets-list :external-f…
	343 (when verbose
	344 (format t "~&...testing STRING-TO-OCTETS"))
	345 (check (equalp (string-to-octets string :external-format …
	346 (when verbose
	347 (format t "~&...testing in-memory streams"))
	348 (check (string= (old-octets-to-string octets-vector :exte…
	349 (check (string= (old-octets-to-string octets-list :extern…
	350 (check (equalp (old-string-to-octets string :external-for…
	351 (loop with simple-test-args-list = (loop for (file-name symbols) i…
	352 nconc (create-test-combin…
	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)…
	367 (flet ((one-sequence-test (pathspec external-format verbose)
	368 (when verbose
	369 (format t "~&With external format ~S:" (normalize-externa…
	370 (let* ((full-path (merge-pathnames pathspec this-file))
	371 (file-string (file-as-string full-path external-form…
	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-extern…
	376 (when verbose
	377 (format t "~&...reading octets"))
	378 #-:openmcl
	379 ;; FLEXI-STREAMS puts integers into the list, but OpenM…
	380 ;; thinks they are characters...
	381 (with-open-file (in full-path :element-type 'octet)
	382 (let* ((in (make-flexi-stream in :external-format ext…
	383 (list (make-list octet-length)))
	384 (setf (flexi-stream-element-type in) 'octet)
	385 #-:clisp
	386 (read-sequence list in)
	387 #+:clisp
	388 (ext:read-byte-sequence list in)
	389 (check (sequence-equal list octets))))
	390 (with-open-file (in full-path :element-type 'octet)
	391 (let* ((in (make-flexi-stream in :external-format ext…
	392 (third (floor octet-length 3))
	393 (half (floor octet-length 2))
	394 (vector (make-array half :element-type 'octet)…
	395 (check (sequence-equal (loop repeat third
	396 collect (read-byte in))
	397 (subseq octets 0 third)))
	398 (read-sequence vector in)
	399 (check (sequence-equal vector (subseq octets third …
	400 (when verbose
	401 (format t "~&...reading characters"))
	402 (with-open-file (in full-path :element-type 'octet)
	403 (let* ((in (make-flexi-stream in :external-format exter…
	404 (string (make-string (- string-length 10) :eleme…
	405 (setf (flexi-stream-element-type in) 'octet)
	406 (check (sequence-equal (loop repeat 10
	407 collect (read-char in))
	408 (subseq file-string 0 10)))
	409 (read-sequence string in)
	410 (check (sequence-equal string (subseq file-string 10)…
	411 (with-open-file (in full-path :element-type 'octet)
	412 (let* ((in (make-flexi-stream in :external-format exter…
	413 (list (make-list (- string-length 100))))
	414 (check (sequence-equal (loop repeat 50
	415 collect (read-char in))
	416 (subseq file-string 0 50)))
	417 #-:clisp
	418 (read-sequence list in)
	419 #+:clisp
	420 (ext:read-char-sequence list in)
	421 (check (sequence-equal list (subseq file-string 50 (-…
	422 (check (sequence-equal (loop repeat 50
	423 collect (read-char in))
	424 (subseq file-string (- string-…
	425 (with-open-file (in full-path :element-type 'octet)
	426 (let* ((in (make-flexi-stream in :external-format exter…
	427 (array (make-array (- string-length 50))))
	428 (check (sequence-equal (loop repeat 25
	429 collect (read-char in))
	430 (subseq file-string 0 25)))
	431 #-:clisp
	432 (read-sequence array in)
	433 #+:clisp
	434 (ext:read-char-sequence array in)
	435 (check (sequence-equal array (subseq file-string 25 (…
	436 (check (sequence-equal (loop repeat 25
	437 collect (read-char in))
	438 (subseq file-string (- string-…
	439 (let ((path-out (ensure-directories-exist (merge-pathname…
	440 (when verbose
	441 (format t "~&...writing sequences"))
	442 (with-open-file (out path-out
	443 :direction :output
	444 :if-exists :supersede
	445 :element-type 'octet)
	446 (let ((out (make-flexi-stream out :external-format ex…
	447 (write-sequence octets out)))
	448 (check (file-equal full-path path-out))
	449 (with-open-file (out path-out
	450 :direction :output
	451 :if-exists :supersede
	452 :element-type 'octet)
	453 (let ((out (make-flexi-stream out :external-format ex…
	454 (write-sequence file-string out)))
	455 (check (file-equal full-path path-out))
	456 (with-open-file (out path-out
	457 :direction :output
	458 :if-exists :supersede
	459 :element-type 'octet)
	460 (let ((out (make-flexi-stream out :external-format ex…
	461 (write-sequence file-string out :end 100)
	462 (write-sequence octets out
	463 :start (length (string-to-octets fi…
	464 :e…
	465 :e…
	466 (check (file-equal full-path path-out))))))
	467
	468 (loop with simple-test-args-list = (loop for (file-name symbols) i…
	469 nconc (create-test-combin…
	470 for (pathspec external-format) in simple-test-args-list
	471 do (one-sequence-test pathspec external-format verbose)))))
	472
	473 (defmacro using-values ((&rest values) &body body)
	474 "Executes BODY and feeds an element from VALUES to the USE-VALUE
	475 restart each time a EXTERNAL-FORMAT-ENCODING-ERROR is signalled.
	476 Signals an error when there are more or less
	477 EXTERNAL-FORMAT-ENCODING-ERRORs than there are elements in VALUES."
	478 (with-unique-names (value-stack condition-counter)
	479 `(let ((,value-stack ',values)
	480 (,condition-counter 0))
	481 (handler-bind ((external-format-encoding-error
	482 #'(lambda (c)
	483 (declare (ignore c))
	484 (unless ,value-stack
	485 (error "Too many encoding errors signalled,…
	486 ,(length values)))
	487 (incf ,condition-counter)
	488 (use-value (pop ,value-stack)))))
	489 (prog1 (progn ,@body)
	490 (when ,value-stack
	491 (error "~A encoding errors signalled, but ~A were expected."
	492 ,condition-counter ,(length values))))))))
	493
	494 (defun accept-overlong (octets code-point)
	495 "Converts the `overlong' UTF-8 sequence OCTETS to using
	496 OCTETS-TO-STRINGS, accepts the expected error with the corresponding
	497 restart and checks that the result is CODE-POINT."
	498 (handler-bind ((external-format-encoding-error
	499 (lambda (c)
	500 (declare (ignore c))
	501 (invoke-restart 'accept-overlong-sequence))))
	502 (string= (octets-to-string octets :external-format :utf-8)
	503 (string (code-char code-point)))))
	504
	505 (defun read-flexi-line (sequence external-format)
	506 "Creates and returns a string from the octet sequence SEQUENCE using
	507 the external format EXTERNAL-FORMAT."
	508 (with-input-from-sequence (in sequence)
	509 (setq in (make-flexi-stream in :external-format external-format))
	510 (read-line in)))
	511
	512 (defun read-flexi-line* (sequence external-format)
	513 "Like READ-FLEXI-LINE but uses OCTETS-TO-STRING internally."
	514 (octets-to-string sequence :external-format external-format))
	515
	516 (defun error-handling-tests (&key verbose)
	517 "Tests several possible errors and how they are handled."
	518 (with-test-suite ("Testing error handling" :show-progress-p (not verbo…
	519 (macrolet ((want-encoding-error (input format)
	520 `(with-expected-error (external-format-encoding-error)
	521 (read-flexi-line* ,input ,format))))
	522 (when verbose
	523 (format t "~&\"Overlong\" UTF-8 sequences"))
	524 (want-encoding-error #(#b11000000 #b10000000) :utf-8)
	525 (want-encoding-error #(#b11000001 #b10000000) :utf-8)
	526 (want-encoding-error #(#b11100000 #b10011111 #b10000000) :utf-8)
	527 (want-encoding-error #(#b11110000 #b10001111 #b10000000 #b10000000…
	528 (check (accept-overlong #(#b11000000 #b10000000) #b00000000))
	529 (check (accept-overlong #(#b11000001 #b10000000) #b01000000))
	530 (check (accept-overlong #(#b11100000 #b10011111 #b10000000) #b0111…
	531 (check (accept-overlong #(#b11110000 #b10001111 #b10000000 #b10000…
	532 #b1111000000000000))
	533 (when verbose
	534 (format t "~&Invalid lead octets in UTF-8"))
	535 (want-encoding-error #(#b11111000) :utf-8)
	536 (want-encoding-error #(#b11111001) :utf-8)
	537 (want-encoding-error #(#b11111100) :utf-8)
	538 (want-encoding-error #(#b11111101) :utf-8)
	539 (want-encoding-error #(#b11111110) :utf-8)
	540 (want-encoding-error #(#b11111111) :utf-8)
	541 (when verbose
	542 (format t "~&Illegal code points"))
	543 (want-encoding-error #(#x00 #x00 #x11 #x00) :utf-32le)
	544 (want-encoding-error #(#x00 #xd8) :utf-16le)
	545 (want-encoding-error #(#xff #xdf) :utf-16le))
	546 (macrolet ((want-encoding-error (input format)
	547 `(with-expected-error (external-format-encoding-error)
	548 (read-flexi-line* ,input ,format))))
	549 (when verbose
	550 (format t "~&UTF-8 sequences which are too short"))
	551 (want-encoding-error #(#xe4 #xf6 #xfc) :utf8)
	552 (want-encoding-error #(#xc0) :utf8)
	553 (want-encoding-error #(#xe0 #xff) :utf8)
	554 (want-encoding-error #(#xf0 #xff #xff) :utf8)
	555 (when verbose
	556 (format t "~&UTF-16 sequences with an odd number of octets"))
	557 (want-encoding-error #(#x01) :utf-16le)
	558 (want-encoding-error #(#x01 #x01 #x01) :utf-16le)
	559 (want-encoding-error #(#x01) :utf-16be)
	560 (want-encoding-error #(#x01 #x01 #x01) :utf-16be)
	561 (when verbose
	562 (format t "~&Missing words in UTF-16"))
	563 (want-encoding-error #(#x01 #xd8) :utf-16le)
	564 (want-encoding-error #(#xd8 #x01) :utf-16be)
	565 (when verbose
	566 (format t "~&Missing octets in UTF-32"))
	567 (want-encoding-error #(#x01) :utf-32le)
	568 (want-encoding-error #(#x01 #x01) :utf-32le)
	569 (want-encoding-error #(#x01 #x01 #x01) :utf-32le)
	570 (want-encoding-error #(#x01 #x01 #x01 #x01 #x01) :utf-32le)
	571 (want-encoding-error #(#x01) :utf-32be)
	572 (want-encoding-error #(#x01 #x01) :utf-32be)
	573 (want-encoding-error #(#x01 #x01 #x01) :utf-32be)
	574 (want-encoding-error #(#x01 #x01 #x01 #x01 #x01) :utf-32be))
	575 (when verbose
	576 (format t "~&Handling of EOF in the middle of CRLF"))
	577 (check (string= #.(string #\Return)
	578 (read-flexi-line `(,(char-code #\Return)) '(:ascii :…
	579 (let ((substitution-char #\?))
	580 (when verbose
	581 (format t "~&Fixed substitution character #\?")
	582 (format t "~&:ASCII doesn't have characters with char codes > 12…
	583 (check (string= "a??" (read-flexi-line `(,(char-code #\a) 128 200)…
	584 (check (string= "a??" (read-flexi-line* `#(,(char-code #\a) 128 20…
	585 (when verbose
	586 (format t "~&:WINDOWS-1253 doesn't have a characters with codes …
	587 (check (string= "a??" (read-flexi-line `(,(char-code #\a) 170 210)…
	588 (check (string= "a??" (read-flexi-line* `#(,(char-code #\a) 170 21…
	589 (when verbose
	590 (format t "~&Not a valid UTF-8 sequence"))
	591 (check (string= "??" (read-flexi-line '(#xe4 #xf6 #xfc) :utf8))))
	592 (let ((substitution-char nil))
	593 (when verbose
	594 (format t "~&Variable substitution using USE-VALUE restart")
	595 (format t "~&:ASCII doesn't have characters with char codes > 12…
	596 (check (string= "abc" (using-values (#\b #\c)
	597 (read-flexi-line `(,(char-code #\a) 128 20…
	598 (check (string= "abc" (using-values (#\b #\c)
	599 (read-flexi-line* `#(,(char-code #\a) 128 …
	600 (when verbose
	601 (format t "~&:WINDOWS-1253 doesn't have a characters with codes …
	602 (check (string= "axy" (using-values (#\x #\y)
	603 (read-flexi-line `(,(char-code #\a) 170 21…
	604 (check (string= "axy" (using-values (#\x #\y)
	605 (read-flexi-line* `#(,(char-code #\a) 170 …
	606 (when verbose
	607 (format t "~&Not a valid UTF-8 sequence"))
	608 (check (string= "QW" (using-values (#\Q #\W) (read-flexi-line '(#x…
	609 (when verbose
	610 (format t "~&UTF-8 can't start neither with #b11111110 nor with …
	611 (check (string= "QW" (using-values (#\Q #\W) (read-flexi-line '(#b…
	612 (when verbose
	613 (format t "~&Only one octet in UTF-16 sequence"))
	614 (check (string= "E" (using-values (#\E) (read-flexi-line '(#x01) :…
	615 (when verbose
	616 (format t "~&Two octets in UTF-16, but value of resulting word s…
	617 (check (string= "R" (using-values (#\R) (read-flexi-line '(#x01 #x…
	618 (when verbose
	619 (format t "~&The second word must fit into the [#xdc00; #xdfff] …
	620 (check (string= "T" (using-values (#\T) (read-flexi-line '(#x01 #x…
	621 (check (string= "T" (using-values (#\T) (read-flexi-line* #(#x01 #…
	622 (when verbose
	623 (format t "~&The same as for little endian above, but using inve…
	624 (check (string= "E" (using-values (#\E) (read-flexi-line '(#x01) :…
	625 (check (string= "R" (using-values (#\R) (read-flexi-line '(#xd8 #x…
	626 (check (string= "T" (using-values (#\T) (read-flexi-line '(#xd8 #x…
	627 (check (string= "T" (using-values (#\T) (read-flexi-line* #(#xd8 #…
	628 (when verbose
	629 (format t "~&EOF in the middle of a 4-octet sequence in UTF-32"))
	630 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01) :…
	631 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x…
	632 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x…
	633 (check (string= "aY" (using-values (#\Y)
	634 (read-flexi-line `(,(char-code #\a) #x00 #x…
	635 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01) :…
	636 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x…
	637 (check (string= "Y" (using-values (#\Y) (read-flexi-line '(#x01 #x…
	638 (check (string= "aY" (using-values (#\Y)
	639 (read-flexi-line `(#x00 #x00 #x00 ,(char-co…
	640
	641 (defun unread-char-tests (&key verbose)
	642 "Tests whether UNREAD-CHAR behaves as expected."
	643 (with-test-suite ("UNREAD-CHAR behaviour." :show-progress-p (and (not …
	644 (flet ((test-one-file (file-name external-format)
	645 (when verbose
	646 (format t "~& ...and external format ~A" (normalize-exte…
	647 (with-open-file (in (merge-pathnames file-name this-file)
	648 :element-type 'flex:octet)
	649 (let ((in (make-flexi-stream in :external-format external…
	650 (loop repeat 300
	651 for char = (read-char in)
	652 do (unread-char char in)
	653 (check (char= (read-char in) char)))))))
	654 (loop for (file-name symbols) in test-files
	655 when verbose
	656 do (format t "~&With file ~S" file-name)
	657 do (loop for symbol in symbols
	658 do (loop for (file-name . external-format) in (crea…
	659 do (test-one-file file-name external-forma…
	660
	661 (defun column-tests (&key verbose)
	662 (with-test-suite ("STREAM-LINE-COLUMN tests" :show-progress-p (not ver…
	663 (let* ((binary-stream (flexi-streams:make-in-memory-output-stream))
	664 (stream (flexi-streams:make-flexi-stream binary-stream :exter…
	665 (write-sequence "hello" stream)
	666 (format stream "~12Tworld")
	667 (finish-output stream)
	668 (check (string= "hello world"
	669 (flexi-streams:octets-to-string
	670 (flexi-streams::vector-stream-vector binary-strea…
	671 :external-format :iso-8859-1)))
	672 (terpri stream)
	673 (check (= 0 (flexi-stream-column stream)))
	674 (write-sequence "abc" stream)
	675 (check (= 3 (flexi-stream-column stream)))
	676 (terpri stream)
	677 (check (= 0 (flexi-stream-column stream))))))
	678
	679 (defun make-external-format-tests (&key verbose)
	680 (with-test-suite ("MAKE-EXTERNAL-FORMAT tests" :show-progress-p (not v…
	681 (flet ((make-case (real-name &key id name)
	682 (list real-name
	683 :id id
	684 :input-names (list name (string-upcase name) (string-do…
	685 (let ((cases (append '((:utf-8 :id nil
	686 :input-names (:utf8 :utf-8 "utf8" "…
	687 (loop for (name . real-name) in +name-map+
	688 unless (member :code-page (list name re…
	689 append (list (make-case real-name :na…
	690 (make-case real-name :na…
	691 (loop for (name . definition) in +shortcut-ma…
	692 for key = (car definition)
	693 for id = (getf (cdr definition) :id)
	694 for expected = (or (cdr (assoc key +nam…
	695 collect (make-case expected :id id :nam…
	696
	697 (loop for (expected-name . kwargs) in cases
	698 for id = (getf kwargs :id)
	699 for input-names = (getf kwargs :input-names)
	700 do (loop for name in input-names
	701 for ext-format = (make-external-format name)
	702 do (check (eq (flex:external-format-name ext-form…
	703 when id
	704 do (check (= (flex:external-format-id ext-forma…
	705
	706 (let ((error-cases '("utf-8 " " utf-8" "utf8 " " utf8" "utf89" :utf8…
	707 (loop for input-name in error-cases
	708 do (with-expected-error (external-format-error)
	709 (make-external-format input-name))))))
	710
	711 (defun peek-byte-tests (&key verbose)
	712 (with-test-suite ("PEEK-BYTE tests" :show-progress-p (not verbose))
	713 (flex:with-input-from-sequence (input #(0 1 2))
	714 (let ((stream (flex:make-flexi-stream input)))
	715 ;; If peek-type was specified as 2 we need to peek the first oct…
	716 (check (= 2 (flex::peek-byte stream 2 nil 1)))
	717 ;; also, the octet should be unread to the stream so that we can…
	718 (check (= 2 (flex::peek-byte stream nil nil nil)))))))
	719
	720 (defun run-all-tests (&key verbose)
	721 "Runs all tests for FLEXI-STREAMS and returns a true value iff all
	722 tests succeeded. VERBOSE is interpreted by the individual test suites
	723 above."
	724 (let ((successp t))
	725 (macrolet ((run-test-suite (&body body)
	726 `(unless (progn ,@body)
	727 (setq successp nil))))
	728 (run-test-suite (compare-files :verbose verbose))
	729 (run-test-suite (string-tests :verbose verbose))
	730 (run-test-suite (sequence-tests :verbose verbose))
	731 (run-test-suite (error-handling-tests :verbose verbose))
	732 (run-test-suite (unread-char-tests :verbose verbose))
	733 (run-test-suite (column-tests :verbose verbose))
	734 (run-test-suite (make-external-format-tests :verbose verbose))
	735 (run-test-suite (peek-byte-tests :verbose verbose))
	736 (format t "~2&~:[Some tests failed~;All tests passed~]." successp)
	737 successp)))