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.
12 (in-package "CL-USER")
14 ;;; In sbcl-0.6.9 FOO-NAMESTRING functions returned "" instead of NIL.
15 (let ((pathname0 (make-pathname :host nil
18 *default-pathname-defaults*)
20 (pathname1 (make-pathname :host nil
23 (assert (equal (file-namestring pathname0) "getty"))
24 (assert (equal (directory-namestring pathname0)
25 (directory-namestring *default-pathname-defaults*)))
26 (assert (equal (file-namestring pathname1) ""))
27 (assert (equal (directory-namestring pathname1) "")))
29 ;;; In sbcl-0.6.9 DIRECTORY failed on paths with :WILD or
30 ;;; :WILD-INFERIORS in their directory components.
31 (let ((dir (directory "../**/*.*")))
32 ;; We know a little bit about the structure of this result;
33 ;; let's test to make sure that this test file is in it.
34 (assert (find-if (lambda (pathname)
35 (search "tests/filesys.pure.lisp"
36 (namestring pathname)))
38 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
40 (let ((dir (directory "[f]*.*")))
41 ;; We know a little bit about the structure of this result;
42 ;; let's test to make sure that this test file is in it.
43 (assert (find-if (lambda (pathname)
44 (search "filesys.pure.lisp"
45 (namestring pathname)))
48 ;;; Set *default-pathname-defaults* to something other than the unix
49 ;;; cwd, to catch functions which access the filesystem without
50 ;;; merging properly. We should test more functions than just OPEN
53 (let ((*default-pathname-defaults*
54 (make-pathname :directory
56 (pathname-directory *default-pathname-defaults*))
57 :defaults *default-pathname-defaults*)))
58 ;; SBCL 0.7.1.2 failed to merge on OPEN
59 (with-open-file (i "tests/filesys.pure.lisp")
62 ;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR
63 ;;; if they are fed wild pathname designators; firstly, with wild
64 ;;; pathnames that don't correspond to any files:
65 (assert (typep (nth-value 1 (ignore-errors (open "non-existent*.lisp")))
67 (assert (typep (nth-value 1 (ignore-errors (load "non-existent*.lisp")))
69 ;;; then for pathnames that correspond to precisely one:
70 (assert (typep (nth-value 1 (ignore-errors (open "filesys.pur*.lisp")))
72 (assert (typep (nth-value 1 (ignore-errors (load "filesys.pur*.lisp")))
74 ;;; then for pathnames corresponding to many:
75 (assert (typep (nth-value 1 (ignore-errors (open "*.lisp")))
77 (assert (typep (nth-value 1 (ignore-errors (load "*.lisp")))
80 ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if
81 ;;; STREAM is not a stream associated with a file.
83 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
84 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
85 (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
88 ;;; A few cases Windows does have enough marbles to pass right now
91 (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
92 (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
93 (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
94 (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t))))
96 (with-test (:name (:parse-native-pathname :as-directory :junk-allowed))
99 (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
101 (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
105 ;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
107 ;;; given only safe characters in the namestring, NATIVE-PATHNAME will
108 ;;; never error, and NATIVE-NAMESTRING on the result will return the
109 ;;; original namestring.
110 (with-test (:name :random-native-namestrings)
114 (loop for x from 32 to 127 collect (code-char x)))
115 'simple-base-string))
116 (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
117 "[]" "*" "**" "/**" "**/" "/**/" "?"
118 "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
120 for length = (random 32)
121 for native-namestring = (coerce
125 (random (length safe-chars))))
127 for pathname = (native-pathname native-namestring)
128 for nnn = (native-namestring pathname)
130 ;; We canonicalize to \ as the directory separator
131 ;; on windows -- though both \ and / are legal.
132 (setf native-namestring (substitute #\\ #\/ native-namestring))
133 (unless (string= nnn native-namestring)
134 (error "1: wanted ~S, got ~S" native-namestring nnn)))
136 for native-namestring = (with-output-to-string (s)
137 (write-string "mu" s)
139 (let ((r (random 1.0)))
141 ((< r 1/20) (return))
145 (random (length safe-chars)))
148 (aref tricky-sequences
150 (length tricky-sequences)))
152 for pathname = (native-pathname native-namestring)
153 for tricky-nnn = (native-namestring pathname)
155 ;; We canonicalize to \ as the directory separator
156 ;; on windows -- though both \ and / are legal.
157 (setf native-namestring (substitute #\\ #\/ native-namestring))
158 (unless (string= tricky-nnn native-namestring)
159 (error "2: wanted ~S, got ~S" native-namestring tricky-nnn)))))
161 ;;; USER-HOMEDIR-PATHNAME and the extension SBCL-HOMEDIR-PATHNAME both
162 ;;; used to call PARSE-NATIVE-NAMESTRING without supplying a HOST
163 ;;; argument, and so would lose when *DEFAULT-PATHNAME-DEFAULTS* was a
164 ;;; logical pathname.
165 (with-test (:name :user-homedir-pathname-robustness)
166 (let ((*default-pathname-defaults* (pathname "SYS:")))
167 (assert (not (typep (user-homedir-pathname)
168 'logical-pathname)))))
170 (with-test (:name :sbcl-homedir-pathname-robustness)
171 (let ((*default-pathname-defaults* (pathname "SYS:")))
172 (assert (not (typep (sb-impl::sbcl-homedir-pathname)
173 'logical-pathname)))))
175 (with-test (:name :file-author-stringp)
177 (assert (stringp (file-author (user-homedir-pathname))))
179 (assert (not (file-author (user-homedir-pathname)))))
180 (with-test (:name :file-write-date-integerp)
181 (assert (integerp (file-write-date (user-homedir-pathname)))))
183 ;;; Canonicalization of pathnames for DIRECTORY
184 (with-test (:name :directory-/.)
185 (assert (equal (directory #p".") (directory #p"./")))
186 (assert (equal (directory #p".") (directory #p""))))
187 (with-test (:name :directory-/..)
188 (assert (equal (directory #p"..") (directory #p"../"))))
189 (with-test (:name :directory-unspecific)
190 (assert (equal (directory #p".")
191 (directory (make-pathname
193 :type :unspecific)))))
196 ;;; (loop for exist in '(nil t)
198 ;;; (loop for (if-exists if-does-not-exist) in '((nil :error)
202 ;;; collect (list 'do-open exist if-exists if-does-not-exist)))
203 (with-test (:name :open-never-openning)
204 (flet ((do-open (existing if-exists if-does-not-exist
205 &optional (direction :output))
207 #.(or *compile-file-truename* *load-truename*)
208 "a-really-non-existing-file")
210 :if-exists if-exists :if-does-not-exist if-does-not-exist)))
211 (assert (raises-error?
212 (do-open nil nil :error)))
214 (do-open nil :error nil)))
216 (do-open t nil :error)))
217 (assert (raises-error?
218 (do-open t :error nil)))
220 (do-open nil nil nil)))
221 (assert (raises-error?
222 (do-open nil :error :error)))
224 (do-open t nil nil)))
225 (assert (raises-error? (do-open t :error :error)))
227 (assert (raises-error?
228 (do-open nil nil :error :io)))
230 (do-open nil :error nil :io)))
232 (do-open t nil :error :io)))
233 (assert (raises-error?
234 (do-open t :error nil :io)))
236 (do-open nil nil nil :io)))
237 (assert (raises-error?
238 (do-open nil :error :error :io)))
240 (do-open t nil nil :io)))
241 (assert (raises-error? (do-open t :error :error :io)))))
243 (with-test (:name :open-new-version)
244 (multiple-value-bind (value error)
245 (ignore-errors (open #.(or *compile-file-truename* *load-truename*)
247 :if-exists :new-version))
250 (assert (equal (simple-condition-format-control error)
251 "OPEN :IF-EXISTS :NEW-VERSION is not supported ~
252 when a new version must be created."))))