1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
14 (defun truename-as-expected-p ()
15 #.
(and (string= (pathname-name *load-pathname
*) (pathname-name *load-truename
*))
16 (string= (pathname-type *load-pathname
*) (pathname-type *load-truename
*))))
18 ;;; In sbcl-0.6.9 DIRECTORY failed on paths with :WILD or
19 ;;; :WILD-INFERIORS in their directory components.
20 (with-test (:name
(directory :wild-inferiors
))
21 (let ((dir (directory "../**/*.*")))
22 ;; We know a little bit about the structure of this result;
23 ;; let's test to make sure that this test file is in it.
24 ;; If the truename of this file is not as expected, the look for only the
25 ;; name+type regardless of directory, treating all parts as essentially random.
27 (if (truename-as-expected-p)
28 "tests/filesys.pure.lisp"
29 (namestring (make-pathname :name
(pathname-name *load-truename
*)
30 :type
(pathname-type *load-truename
*))))))
31 (assert (find string-to-find dir
32 :test
#'search
:key
#'namestring
)))))
34 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
36 (with-test (:name
(directory :character-set
:pattern
))
37 ;; In addition to potential truename randomization,
38 ;; do not assume that the current directory is the place to look.
39 (let* ((pattern (if (truename-as-expected-p)
41 (format nil
"~a[~a]*~:[~;.*~]"
43 (make-pathname :directory
(pathname-directory *load-truename
*)))
44 (char (pathname-name *load-truename
*) 0)
45 (pathname-type *load-truename
*))))
46 (string-to-find (if (truename-as-expected-p)
48 (pathname-name *load-truename
*)))
49 (dir (directory pattern
)))
50 (assert (find string-to-find dir
:test
#'search
:key
#'namestring
))))
52 ;;; Canonicalization of pathnames for DIRECTORY
53 (with-test (:name
(directory :/.
))
54 (assert (equal (directory #p
".") (directory #p
"./")))
55 (assert (equal (directory #p
".") (directory #p
""))))
56 (with-test (:name
(directory :/..
))
57 (assert (equal (directory #p
"..") (directory #p
"../"))))
58 (with-test (:name
(directory :unspecific
))
59 (assert (equal (directory #p
".")
60 (directory (make-pathname
62 :type
:unspecific
)))))
64 ;;; This used to signal a TYPE-ERROR.
65 (with-test (:name
(directory :..
*))
66 (directory "somedir/..*"))
68 (with-test (:name
(directory *default-pathname-defaults
* :bug-1740563
))
69 (with-test-directory ()
70 (close (open "a.txt" :if-does-not-exist
:create
))
71 (close (open "b.lisp" :if-does-not-exist
:create
))
72 (flet ((directory* (pattern &rest d-p-d-components
)
73 (let ((*default-pathname-defaults
*
74 (apply #'make-pathname
75 :defaults
*default-pathname-defaults
*
77 (directory pattern
))))
78 (let* ((expected-wild (directory "*.*"))
79 (expected-one-file (directory "a.txt"))
80 (cases '((:name nil
:type
"txt")
81 (:name nil
:type
:wild
)
83 (:name
"a" :type
"txt")
84 (:name
"a" :type
:wild
)
85 (:name
:wild
:type nil
)
86 (:name
:wild
:type
:wild
)
87 (:name
:wild
:type
"txt"))))
88 (dolist (components cases
)
89 (assert (equal (apply #'directory
* "*.*" components
)
91 (assert (equal (apply #'directory
* "a.txt" components
)
93 (assert (equal (directory* "" :name
:wild
:type
:wild
)
98 ;;; In sbcl-0.6.9 FOO-NAMESTRING functions returned "" instead of NIL.
99 (with-test (:name
(file-namestring directory-namestring
:name
))
100 (let ((pathname0 (make-pathname :host nil
103 *default-pathname-defaults
*)
105 (pathname1 (make-pathname :host nil
108 (assert (equal (file-namestring pathname0
) "getty"))
109 (assert (equal (directory-namestring pathname0
)
110 (directory-namestring *default-pathname-defaults
*)))
111 (assert (equal (file-namestring pathname1
) ""))
112 (assert (equal (directory-namestring pathname1
) ""))))
114 ;;; Set *default-pathname-defaults* to something other than the unix
115 ;;; cwd, to catch functions which access the filesystem without
116 ;;; merging properly. We should test more functions than just OPEN
119 (with-test (:name
(open *default-pathname-defaults
*))
120 (let ((*default-pathname-defaults
*
121 (make-pathname :directory
123 (pathname-directory *default-pathname-defaults
*))
124 :defaults
*default-pathname-defaults
*)))
125 ;; SBCL 0.7.1.2 failed to merge on OPEN
126 (with-open-file (i "tests/filesys.pure.lisp")
129 ;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR
130 ;;; if they are fed wild pathname designators; firstly, with wild
131 ;;; pathnames that don't correspond to any files:
132 (with-test (:name
(open :wild file-error
1))
133 (assert-error (open "non-existent*.lisp") file-error
))
134 (with-test (:name
(load :wild file-error
1))
135 (assert-error (load "non-existent*.lisp") file-error
))
136 ;;; then for pathnames that correspond to precisely one:
137 (with-test (:name
(open :wild file-error
2))
138 (assert-error (open "filesys.pur*.lisp") file-error
))
139 (with-test (:name
(load :wild file-error
2))
140 (assert-error (load "filesys.pur*.lisp") file-error
))
141 ;;; then for pathnames corresponding to many:
142 (with-test (:name
(open :wild file-error
3))
143 (assert-error (open "*.lisp") file-error
))
144 (with-test (:name
(load :wild file-error
3))
145 (assert-error (load "*.lisp") file-error
))
147 ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if
148 ;;; STREAM is not a stream associated with a file.
150 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
151 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
152 (with-test (:name
(file-length *terminal-io
* type-error
))
153 (assert-error (file-length *terminal-io
*) type-error
))
155 (with-test (:name
(file-length synonym-stream
))
156 (with-open-file (*stream
* "filesys.pure.lisp" :direction
:input
)
157 (declare (special *stream
*))
158 (assert (integerp (file-length (make-synonym-stream '*stream
*))))
159 (let ((*stream2
* (make-synonym-stream '*stream
*)))
160 (declare (special *stream2
*))
161 (assert (integerp (file-length (make-synonym-stream '*stream2
*)))))))
163 ;;; A few cases Windows does have enough marbles to pass right now
164 (with-test (:name
(sb-ext:native-namestring
:win32
)
165 :skipped-on
(not :win32
))
166 (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
167 (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
168 (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
169 (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t
))))
171 (with-test (:name
(sb-ext:parse-native-namestring
:as-directory
:junk-allowed
))
174 (parse-native-namestring "foo.lisp" nil
*default-pathname-defaults
*
176 (parse-native-namestring "foo.lisp" nil
*default-pathname-defaults
*
180 ;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
182 ;;; given only safe characters in the namestring, NATIVE-PATHNAME will
183 ;;; never error, and NATIVE-NAMESTRING on the result will return the
184 ;;; original namestring.
185 (with-test (:name
(sb-ext:native-namestring sb-ext
:native-pathname
:random
))
189 (loop for x from
32 to
127 collect
(code-char x
)))
190 'simple-base-string
))
191 (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
192 "[]" "*" "**" "/**" "**/" "/**/" "?"
193 "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
196 ;; We canonicalize to \ as the directory separator
197 ;; on windows -- though both \ and / are legal.
198 (substitute #\\ #\
/ s
)
200 ;; Consecutive separators become a single separator
201 (let ((p (search "//" s
)))
203 (canon (concatenate 'string
(subseq s
0 p
) (subseq s
(1+ p
))))
205 (loop for length
= (random 32)
206 for native-namestring
= (coerce
210 (random (length safe-chars
))))
212 for pathname
= (native-pathname native-namestring
)
213 for nnn
= (native-namestring pathname
)
215 do
(setf native-namestring
(canon native-namestring
))
216 (unless (string= nnn native-namestring
)
217 (error "1: wanted ~S, got ~S" native-namestring nnn
)))
218 (loop for native-namestring
= (with-output-to-string (s)
219 (write-string "mu" s
)
221 (let ((r (random 1.0)))
223 ((< r
1/20) (return))
227 (random (length safe-chars
)))
230 (aref tricky-sequences
232 (length tricky-sequences
)))
234 for pathname
= (native-pathname native-namestring
)
235 for tricky-nnn
= (native-namestring pathname
)
237 do
(setf native-namestring
(canon native-namestring
))
238 (unless (string= tricky-nnn native-namestring
)
239 (error "2: wanted ~S, got ~S" native-namestring tricky-nnn
))))))
241 ;;; USER-HOMEDIR-PATHNAME and the extension SBCL-HOMEDIR-PATHNAME both
242 ;;; used to call PARSE-NATIVE-NAMESTRING without supplying a HOST
243 ;;; argument, and so would lose when *DEFAULT-PATHNAME-DEFAULTS* was a
244 ;;; logical pathname.
245 (with-test (:name
(user-homedir-pathname :robustness
))
246 (let ((*default-pathname-defaults
* (pathname "SYS:")))
247 (assert (not (typep (user-homedir-pathname)
248 'logical-pathname
)))))
250 (with-test (:name
(sb-int:sbcl-homedir-pathname
:robustness
))
251 (let ((*default-pathname-defaults
* (pathname "SYS:")))
252 (assert (not (typep (sb-int:sbcl-homedir-pathname
)
253 'logical-pathname
)))))
255 (with-test (:name
(file-author stringp
))
257 (assert (stringp (file-author (user-homedir-pathname))))
259 (assert (not (file-author (user-homedir-pathname)))))
260 (with-test (:name
(file-write-date integerp
))
261 (assert (integerp (file-write-date (user-homedir-pathname)))))
264 ;;; (loop for exist in '(nil t)
266 ;;; (loop for (if-exists if-does-not-exist) in '((nil :error)
270 ;;; collect (list 'do-open exist if-exists if-does-not-exist)))
271 (with-test (:name
(open :never-openning
))
272 (flet ((do-open (existing if-exists if-does-not-exist
273 &optional
(direction :output
))
275 #.
(or *compile-file-truename
* *load-truename
*)
276 "a-really-non-existing-file")
278 :if-exists if-exists
:if-does-not-exist if-does-not-exist
)))
279 (assert-error (do-open nil nil
:error
) file-error
)
280 (assert (not (do-open nil
:error nil
)))
281 (assert (not (do-open t nil
:error
)))
282 (assert-error (do-open t
:error nil
) file-error
)
283 (assert (not (do-open nil nil nil
)))
284 (assert-error (do-open nil
:error
:error
) file-error
)
285 (assert (not (do-open t nil nil
)))
286 (assert-error (do-open t
:error
:error
))
288 (assert-error (do-open nil nil
:error
:io
) file-error
)
289 (assert (not (do-open nil
:error nil
:io
)))
290 (assert (not (do-open t nil
:error
:io
)))
291 (assert-error (do-open t
:error nil
:io
) file-error
)
292 (assert (not (do-open nil nil nil
:io
)))
293 (assert-error (do-open nil
:error
:error
:io
) file-error
)
294 (assert (not (do-open t nil nil
:io
)))
295 (assert-error (do-open t
:error
:error
:io
) file-error
)))
297 (with-test (:name
(open :new-version
))
298 (multiple-value-bind (value error
)
299 (ignore-errors (open #.
(or *compile-file-truename
* *load-truename
*)
301 :if-exists
:new-version
))
304 (let ((control (simple-condition-format-control error
)))
305 (assert (search "OPEN :IF-EXISTS :NEW-VERSION is not supported" control
))
306 (assert (search "when a new version must be created." control
)))))
308 (with-test (:name
(parse-native-namestring :canon
) :skipped-on
(not :unix
))
309 (let ((pathname (parse-native-namestring "foo/bar//baz")))
310 (assert (string= (car (last (pathname-directory pathname
))) "bar"))))
313 ;;;; DELETE-DIRECTORY
315 (with-test (:name
(delete-directory :as-file
:complicated-name-or-type
:bug-1740624
))
316 ;; This test creates directories whose names are in some way
317 ;; complicated to express as the filename part of a pathname, for
318 ;; example by including characters that need escaping in namestrings
319 ;; or looking like a :type component without a :name
320 ;; component. DELETE-DIRECTORY is applied to pathnames with filename
321 ;; parts to delete these directories. The intention is testing the
322 ;; translation from filename part to directory component employed by
324 (labels ((prepare (string)
325 #-win32
(substitute #\\ #\E string
)
326 #+win32
(substitute #\^
#\E string
))
328 (make-pathname :type
(prepare type
)))
329 (make-unspecific (namep typep
)
330 (apply #'make-pathname
331 :directory
'(:relative
"foo")
332 (append (when namep
'(:name
:unspecific
))
333 (when typep
'(:type
:unspecific
)))))
334 (test (as-file as-directory
)
335 (with-test-directory (test-directory)
336 (let ((delete-directory (merge-pathnames
338 (string (prepare as-file
))
341 (ensure-directories-exist (merge-pathnames
342 (prepare as-directory
)
344 (delete-directory delete-directory
)
345 (assert (not (probe-file (prepare as-directory
))))))))
346 ;; Name component present
347 #-win32
(test "aE?b" "aE?b/")
348 #-win32
(test "aE*b" "aE*b/")
349 (test "aE[cd]b" "aE[cd]b/")
350 (test "aEEb" "aEEb/")
352 #-win32
(test (make-type "a?b") ".aE?b/")
353 #-win32
(test (make-type "a*b") ".aE*b/")
354 (test (make-type "a[cd]b") ".aE[cd]b/")
355 (test (make-type "aEb") ".aEEb/")
356 ;; Name and type components present
357 #-win32
(test "foo.aE?b" "foo.aE?b/")
358 #-win32
(test "foo.aE*b" "foo.aE*b/")
359 (test "foo.aE[cd]b" "foo.aE[cd]b/")
360 (test "foo.aEEb" "foo.aEEb/")
361 ;; Name and/or type :unspecific
362 (test (make-unspecific nil nil
) "foo/")
363 (test (make-unspecific nil t
) "foo/")
364 (test (make-unspecific t nil
) "foo/")
365 (test (make-unspecific t t
) "foo/")))
367 (with-test (:name
(rename-file :overwrite
))
368 (with-test-directory ()
369 (with-open-file (s "a" :direction
:output
)
371 (with-open-file (s "b" :direction
:output
)
373 (rename-file "a" "b")
374 (assert (null (probe-file "a")))
375 (with-open-file (s "b")
376 (assert (equal "a" (read-line s
))))))