1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; streams.lisp --- IO.STREAMS test suite.
5 ;;; Copyright (c) 2006-2007, Dr. Edmund Weitz. All rights reserved.
6 ;;; Copyright (c) 2007, Luis Oliveira <loliveira@common-lisp.net>
8 ;;; Redistribution and use in source and binary forms, with or without
9 ;;; modification, are permitted provided that the following conditions
12 ;;; * Redistributions of source code must retain the above copyright
13 ;;; notice, this list of conditions and the following disclaimer.
15 ;;; * Redistributions in binary form must reproduce the above
16 ;;; copyright notice, this list of conditions and the following
17 ;;; disclaimer in the documentation and/or other materials
18 ;;; provided with the distribution.
20 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
21 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
22 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
24 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
26 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
28 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 (in-package #:iolib-tests
)
34 (defclass my-file-stream
(dual-channel-single-fd-gray-stream)
35 ((path :initarg
:path
:reader file-stream-path
)))
37 (defmethod close :after
((file my-file-stream
) &key abort
)
38 (declare (ignore abort
))
39 (nix:close
(fd-of file
)))
41 ;;; Very ad-hoc: doesn't do :DIRECTION :PROBE, or handle errors,
42 ;;; :IF-DOES-NOT-EXIST, among many other things. This kind of thing
43 ;;; should be moved into OSICAT, btw.
45 ;;; FIXME: implement single-channel stream
46 (defun make-file-stream (path &key
49 (if-does-not-exist (ecase direction
51 ((:io
:output
) :create
)))
52 (external-format :default
))
53 (declare (ignore if-does-not-exist
))
54 ;; move OPEN to INITIALIZE-INSTANCE
55 (let ((fd (nix:open path
56 (logior (ecase direction
58 (:output
(logior nix
:o-creat nix
:o-wronly
))
59 (:io
(logior nix
:o-creat nix
:o-rdwr
)))
62 (:supersede nix
:o-trunc
)
63 (:append nix
:o-append
)
65 (logior nix
:s-irusr nix
:s-iwusr
))))
66 (make-instance 'my-file-stream
70 :external-format external-format
)))
72 (defmacro with-open-file-stream
((var path
&rest options
) &body body
)
73 (with-unique-names (stream)
74 `(let ((,stream
(make-file-stream ,path
,@options
)))
75 (with-open-stream (,var
,stream
)
79 (let ((sys-pn (asdf:system-definition-pathname
80 (asdf:find-system
'iolib-tests
))))
81 (make-pathname :directory
(append (pathname-directory sys-pn
)
86 (ensure-directories-exist
88 (make-pathname :directory
'(:relative
"test-dir"))
89 (make-pathname :directory
91 (or *load-truename
* *compile-file-truename
*))))))
93 ;;; A list of test files where each entry consists of the name
94 ;;; prefix and a list of encodings.
96 '(("kafka" (:utf-8
:latin-1
#|
:cp1252|
#))
97 ("tilton" (:utf-8
:ascii
))
98 ("hebrew" (:utf-8
#|
:latin-8|
#))
99 ("russian" (:utf-8
#|
:koi8r|
#))
100 ("unicode_demo" (:utf-8
#|
:utf-16
:utf-32|
#))))
102 ;;; For a name suffix FILE-NAME and a symbol SYMBOL denoting an
103 ;;; encoding returns a list of pairs where the car is a full file name
104 ;;; and the cdr is the corresponding external format. This list
105 ;;; contains all possible line-end conversions.
106 (defun create-file-variants (file-name symbol
)
107 (loop for eol-style in
'(:lf
:cr
:crlf
) collect
108 (cons (format nil
"~A_~(~A~)_~(~A~).txt"
109 file-name symbol eol-style
)
110 (babel:make-external-format symbol eol-style
))))
112 ;;; For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting
113 ;;; different encodings of the corresponding file returns a list of
114 ;;; lists which can be used as arglists for COMPARE-FILES.
115 (defun create-test-combinations (file-name symbols
)
116 (let ((file-variants (loop for symbol in symbols
117 nconc
(create-file-variants file-name symbol
))))
118 (loop for
(name-in . external-format-in
) in file-variants
119 nconc
(loop for
(name-out . external-format-out
) in file-variants
120 collect
(list name-in external-format-in
121 name-out external-format-out
)))))
123 ;;; Returns a true value iff FILE1 and FILE2 have the same contents
124 ;;; (viewed as binary files).
125 (defun file-equal (file1 file2
)
126 (with-open-file (stream1 file1
:element-type
'(unsigned-byte 8))
127 (with-open-file (stream2 file2
:element-type
'(unsigned-byte 8))
128 (and (= (file-length stream1
) (file-length stream2
))
129 (loop for byte1
= (read-byte stream1 nil nil
)
130 for byte2
= (read-byte stream2 nil nil
)
131 while
(and byte1 byte2
)
132 always
(= byte1 byte2
))))))
134 ;;; Copies the contents of the file denoted by the pathname PATH-IN to
135 ;;; the file denoted by the pathname PATH-OUT using flexi streams -
136 ;;; STREAM-IN is read with the external format EXTERNAL-FORMAT-IN and
137 ;;; STREAM-OUT is written with EXTERNAL-FORMAT-OUT. The input file is
138 ;;; opened with the :DIRECTION keyword argument DIRECTION-IN, the
139 ;;; output file is opened with the :DIRECTION keyword argument
141 (defun copy-file (path-in external-format-in path-out external-format-out
142 direction-out direction-in
)
143 (with-open-file-stream (in path-in
144 :direction direction-in
145 :if-does-not-exist
:error
146 :if-exists
:overwrite
147 :external-format external-format-in
)
148 (with-open-file-stream (out path-out
149 :direction direction-out
150 :if-does-not-exist
:create
151 :if-exists
:supersede
152 :external-format external-format-out
)
153 (loop for line
= (read-line in nil nil
)
154 while line do
(write-line line out
)))))
158 (babel-encodings:enc-name
(babel:external-format-encoding ef
))
159 (babel:external-format-eol-style ef
)))
161 ;;; Copies the contents of the file (in the 'test') denoted by the
162 ;;; relative pathname PATH-IN to the file (in a temporary directory)
163 ;;; denoted by the relative pathname PATH-OUT using flexi streams -
164 ;;; STREAM-IN is read with the external format EXTERNAL-FORMAT-IN and
165 ;;; STREAM-OUT is written with EXTERNAL-FORMAT-OUT. The resulting
166 ;;; file is compared with an existing file in the 'test' directory to
167 ;;; check if the outcome is as expected. Uses various variants of the
168 ;;; :DIRECTION keyword when opening the files."
169 (defun compare-files (path-in external-format-in path-out external-format-out
)
170 (let ((full-path-in (merge-pathnames path-in
*data-dir
*))
171 (full-path-out (merge-pathnames path-out
*test-dir
*))
172 (full-path-orig (merge-pathnames path-out
*data-dir
*)))
173 (dolist (direction-out '(:output
:io
) t
)
174 (dolist (direction-in '(:input
:io
))
175 (let ((description (format nil
"Test ~S ~A [~A] --> ~A [~A]"
176 path-in
(ef-name external-format-in
)
177 direction-in
(ef-name external-format-out
)
179 (format *error-output
* "~&;; ~A.~%" description
)
180 (copy-file full-path-in external-format-in
181 full-path-out external-format-out
182 direction-out direction-in
)
183 (unless (file-equal full-path-out full-path-orig
)
184 (format *error-output
* "~&;; Test failed!!!~%")
185 (return-from compare-files nil
)))))))
187 (deftest big-stream-comparision-test
188 (let ((args-list (loop for
(file-name symbols
) in
*test-files
*
189 nconc
(create-test-combinations file-name symbols
))))
190 (loop for args in args-list
191 unless
(apply #'compare-files args
)