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 (truename (asdf:system-definition-pathname
80 (asdf:find-system
'iolib-tests
)))))
81 (make-pathname :directory
(append (pathname-directory sys-pn
)
85 (ensure-directories-exist
87 (make-pathname :directory
'(:relative
"test-dir"))
88 (make-pathname :directory
90 (or *load-truename
* *compile-file-truename
*))))))
92 ;;; A list of test files where each entry consists of the name
93 ;;; prefix and a list of encodings.
95 '(("kafka" (:utf-8
:latin-1
#|
:cp1252|
#))
96 ("tilton" (:utf-8
:ascii
))
97 ("hebrew" (:utf-8
#|
:latin-8|
#))
98 ("russian" (:utf-8
#|
:koi8r|
#))
99 ("unicode_demo" (:utf-8
#|
:utf-16
:utf-32|
#))))
101 ;;; For a name suffix FILE-NAME and a symbol SYMBOL denoting an
102 ;;; encoding returns a list of pairs where the car is a full file name
103 ;;; and the cdr is the corresponding external format. This list
104 ;;; contains all possible line-end conversions.
105 (defun create-file-variants (file-name symbol
)
106 (loop :for eol-style
:in
'(:lf
:cr
:crlf
) :collect
107 (cons (format nil
"~A_~(~A~)_~(~A~).txt"
108 file-name symbol eol-style
)
109 (babel:make-external-format symbol eol-style
))))
111 ;;; For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting
112 ;;; different encodings of the corresponding file returns a list of
113 ;;; lists which can be used as arglists for COMPARE-FILES.
114 (defun create-test-combinations (file-name symbols
)
115 (let ((file-variants (loop :for symbol
:in symbols
116 :nconc
(create-file-variants file-name symbol
))))
117 (loop :for
(name-in . external-format-in
) :in file-variants
118 :nconc
(loop :for
(name-out . external-format-out
) :in file-variants
119 :collect
(list name-in external-format-in
120 name-out external-format-out
)))))
122 ;;; Returns a true value iff FILE1 and FILE2 have the same contents
123 ;;; (viewed as binary files).
124 (defun file-equal (file1 file2
)
125 (with-open-file (stream1 file1
:element-type
'(unsigned-byte 8))
126 (with-open-file (stream2 file2
:element-type
'(unsigned-byte 8))
127 (and (= (file-length stream1
) (file-length stream2
))
128 (loop :for byte1
:= (read-byte stream1 nil nil
)
129 :for byte2
:= (read-byte stream2 nil nil
)
130 :while
(and byte1 byte2
)
131 :always
(= byte1 byte2
))))))
133 ;;; Copies the contents of the file denoted by the pathname PATH-IN to
134 ;;; the file denoted by the pathname PATH-OUT using flexi streams -
135 ;;; STREAM-IN is read with the external format EXTERNAL-FORMAT-IN and
136 ;;; STREAM-OUT is written with EXTERNAL-FORMAT-OUT. The input file is
137 ;;; opened with the :DIRECTION keyword argument DIRECTION-IN, the
138 ;;; output file is opened with the :DIRECTION keyword argument
140 (defun copy-file (path-in external-format-in path-out external-format-out
141 direction-out direction-in
)
142 (with-open-file-stream (in path-in
143 :direction direction-in
144 :if-does-not-exist
:error
145 :if-exists
:overwrite
146 :external-format external-format-in
)
147 (with-open-file-stream (out path-out
148 :direction direction-out
149 :if-does-not-exist
:create
150 :if-exists
:supersede
151 :external-format external-format-out
)
152 (loop :for line
:= (read-line in nil nil
)
153 :while line
:do
(write-line line out
)))))
157 (babel-encodings:enc-name
(babel:external-format-encoding ef
))
158 (babel:external-format-eol-style ef
)))
160 ;;; Copies the contents of the file (in the 'test') denoted by the
161 ;;; relative pathname PATH-IN to the file (in a temporary directory)
162 ;;; denoted by the relative pathname PATH-OUT using flexi streams -
163 ;;; STREAM-IN is read with the external format EXTERNAL-FORMAT-IN and
164 ;;; STREAM-OUT is written with EXTERNAL-FORMAT-OUT. The resulting
165 ;;; file is compared with an existing file in the 'test' directory to
166 ;;; check if the outcome is as expected. Uses various variants of the
167 ;;; :DIRECTION keyword when opening the files."
168 (defun compare-files (path-in external-format-in path-out external-format-out
)
169 (let ((full-path-in (merge-pathnames path-in
*data-dir
*))
170 (full-path-out (merge-pathnames path-out
*test-dir
*))
171 (full-path-orig (merge-pathnames path-out
*data-dir
*)))
172 (dolist (direction-out '(:output
:io
) t
)
173 (dolist (direction-in '(:input
:io
))
174 (let ((description (format nil
"Test ~S ~A [~A] --> ~A [~A]"
175 path-in
(ef-name external-format-in
)
176 direction-in
(ef-name external-format-out
)
178 (format *error-output
* "~&;; ~A.~%" description
)
179 (copy-file full-path-in external-format-in
180 full-path-out external-format-out
181 direction-out direction-in
)
182 (unless (file-equal full-path-out full-path-orig
)
183 (format *error-output
* "~&;; Test failed!!!~%")
184 (return-from compare-files nil
)))))))
186 (deftest big-stream-comparision-test
187 (let ((args-list (loop :for
(file-name symbols
) :in
*test-files
*
188 :nconc
(create-test-combinations file-name symbols
))))
189 (loop :for args
:in args-list
190 :unless
(apply #'compare-files args
)