1 ;;;; miscellaneous tests of pathname-related stuff
3 ;;;; This file is naturally impure because we mess with
4 ;;;; LOGICAL-PATHNAME-TRANSLATIONS.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; While most of SBCL is derived from the CMU CL system, the test
10 ;;;; files (like this one) were written from scratch after the fork
13 ;;;; This software is in the public domain and is provided with
14 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
15 ;;;; more information.
17 (load "assertoid.lisp")
18 (use-package "ASSERTOID")
20 (load "test-util.lisp")
21 (use-package "TEST-UTIL")
23 ;;;; Pathname accessors
25 (with-test (:name
(pathname :accessors
:stream-not-associated-to-file type-error
))
26 (let ((*stream
* (make-string-output-stream)))
27 (declare (special *stream
*))
28 (checked-compile-and-assert ()
29 '(lambda (pathname) (pathname-host pathname
))
30 (((make-string-output-stream)) (condition 'type-error
))
31 (((make-synonym-stream '*stream
*)) (condition 'type-error
)))))
33 (with-test (:name
(pathname :accessors file-stream
))
34 (let* ((name "pathnames.impure")
36 (with-open-file (stream (make-pathname :name name
:type type
))
37 (assert (equal (pathname-name stream
) name
))
38 (assert (equal (pathname-type stream
) type
)))))
40 (with-test (:name
(pathname :accessors synonym-stream
))
41 (let* ((name "pathnames.impure")
43 (with-open-file (stream (make-pathname :name name
:type type
))
44 (let* ((*stream1
* stream
)
45 (stream1 (make-synonym-stream '*stream1
*))
47 (stream2 (make-synonym-stream '*stream2
*)))
48 (declare (special *stream1
* *stream2
*))
49 (assert (equal (pathname-name stream1
) name
))
50 (assert (equal (pathname-name stream2
) name
))
51 (assert (equal (pathname-type stream1
) type
))
52 (assert (equal (pathname-type stream2
) type
))))))
54 (labels ((unpattern (thing)
57 (list* (unpattern (first thing
))
58 (map 'list
#'unpattern
(rest thing
))))
60 (sb-impl::pattern-pieces thing
))
65 ((cons (member :absolute
:relative
))
66 (list* (pattern (first thing
))
67 (map 'list
#'pattern
(cdr thing
))))
69 (sb-impl::make-pattern thing
))
72 (accessor-cases (initarg accessor cases
)
73 (map nil
(lambda (test-case)
74 (destructuring-bind (pathname case expected
) test-case
75 ;; Check accessor directory.
76 (let ((result (funcall accessor pathname
:case case
)))
77 (assert (equal (unpattern result
) expected
)))
79 (let* ((pathname (make-pathname initarg
(pattern expected
) :case case
))
80 (result (funcall accessor pathname
:case case
)))
81 (assert (equal (unpattern result
) expected
)))))
84 (with-test (:name
(pathname-device :case
))
86 :device
#'pathname-device
87 `((,(make-pathname :device
"foo") :local
"foo")
88 (,(make-pathname :device
"FOO") :local
"FOO")
89 (,(make-pathname :device
"Foo") :local
"Foo")
91 (,(make-pathname :device
"foo") :common
"FOO")
92 (,(make-pathname :device
"FOO") :common
"foo")
93 (,(make-pathname :device
"Foo") :common
"Foo"))))
95 (with-test (:name
(pathname-directory :case
))
97 :directory
#'pathname-directory
98 `((,#P
"/ab/cd/" :local
(:absolute
"ab" "cd"))
99 (,#P
"/AB/CD/" :local
(:absolute
"AB" "CD"))
100 (,#P
"/Ab/Cd/" :local
(:absolute
"Ab" "Cd"))
101 (,#P
"/AB/cd/" :local
(:absolute
"AB" "cd"))
102 (,#P
"/a*b/" :local
(:absolute
("a" :multi-char-wild
"b")))
104 (,#P
"/ab/cd/" :common
(:absolute
"AB" "CD"))
105 (,#P
"/AB/CD/" :common
(:absolute
"ab" "cd"))
106 (,#P
"/Ab/Cd/" :common
(:absolute
"Ab" "Cd"))
107 (,#P
"/AB/cd/" :common
(:absolute
"ab" "CD"))
108 (,#P
"/a*b/" :common
(:absolute
("A" :multi-char-wild
"B"))))))
110 (with-test (:name
(pathname-name :case
))
112 :name
#'pathname-name
113 `((,#P
"foo" :local
"foo")
114 (,#P
"FOO" :local
"FOO")
115 (,#P
"Foo" :local
"Foo")
116 (,#P
"a*b" :local
("a" :multi-char-wild
"b"))
118 (,#P
"foo" :common
"FOO")
119 (,#P
"FOO" :common
"foo")
120 (,#P
"Foo" :common
"Foo")
121 (,#P
"a*b" :common
("A" :multi-char-wild
"B")))))
123 (with-test (:name
(pathname-type :case
))
125 :type
#'pathname-type
126 `((,#P
"n.foo" :local
"foo")
127 (,#P
"n.FOO" :local
"FOO")
128 (,#P
"n.Foo" :local
"Foo")
129 (,#P
"n.a*b" :local
("a" :multi-char-wild
"b"))
131 (,#P
"n.foo" :common
"FOO")
132 (,#P
"n.FOO" :common
"foo")
133 (,#P
"n.Foo" :common
"Foo")
134 (,#P
"n.a*b" :common
("A" :multi-char-wild
"B"))))))
137 ;;;; Logical pathnames
139 (setf (logical-pathname-translations "demo0")
140 '(("**;*.*.*" "/tmp/")))
142 ;;; In case of a parse error we want to get a condition of type TYPE-ERROR,
143 ;;; because ANSI says so. (This used to be PARSE-ERROR.)
144 (with-test (:name
(logical-pathname :signals type-error
))
145 (mapc (lambda (namestring)
146 (assert-error (logical-pathname namestring
) type-error
))
147 '("demo0::bla;file.lisp"
151 ;;; some things SBCL-0.6.9 used not to parse correctly:
153 ;;; SBCL used to signal an error saying there's no translation.
154 (with-test (:name
(:logical-pathname
1))
155 (assert (equal (namestring (translate-logical-pathname "demo0:file.lisp"))
158 ;;; We do not match a null directory to every wild path:
159 (with-test (:name
(:logical-pathname
2))
160 (assert (not (pathname-match-p "demo0:file.lisp"
161 (logical-pathname "demo0:tmp;**;*.*.*")))))
163 ;;; Remove "**" from our resulting pathname when the source-dir is NIL:
164 (with-test (:name
(:logical-pathname
3))
165 (setf (logical-pathname-translations "demo1")
166 '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*")))
167 (assert (not (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
168 "/tmp/**/foo.lisp"))))
170 ;;; That should be correct:
171 (with-test (:name
(:logical-pathname
4))
172 (assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
175 ;;; Check for absolute/relative path confusion:
176 (with-test (:name
(:logical-pathname
5))
177 (assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
178 "tmp/rel/foo.lisp")))
179 (assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
180 "/tmp/rel/foo.lisp")))
182 ;;; Under SBCL: new function #'UNPARSE-ENOUGH-NAMESTRING, to
183 ;;; handle the following case exactly (otherwise we get an error:
184 ;;; "#'IDENTITY CALLED WITH 2 ARGS."
185 (with-test (:name
(:logical-pathname
6))
186 (setf (logical-pathname-translations "demo2")
187 '(("test;**;*.*" "/tmp/demo2/test")))
188 (enough-namestring "demo2:test;foo.lisp"))
190 ;;; When a pathname comes from a logical host, it should be in upper
191 ;;; case. (This doesn't seem to be specifically required in the ANSI
192 ;;; spec, but it's left up to the implementors, and the arguments made
193 ;;; in the cleanup issue PATHNAME-LOGICAL:ADD seem to be a pretty
194 ;;; compelling reason for the implementors to choose case
195 ;;; insensitivity and a canonical case.)
196 (with-test (:name
(:logical-pathname
7))
197 (setf (logical-pathname-translations "FOO")
198 '(("**;*.*.*" "/full/path/to/foo/**/*.*")))
199 (let* ((pn1 (make-pathname :host
"FOO" :directory
"etc" :name
"INETD"
201 (pn2 (make-pathname :host
"foo" :directory
"ETC" :name
"inetd"
203 (pn3 (read-from-string (prin1-to-string pn1
))))
204 (assert (equal pn1 pn2
))
205 (assert (equal pn1 pn3
))))
207 ;;; In addition to the upper-case constraint above, if the logical-pathname
208 ;;; contains a string component in e.g. the directory, name and type slot,
209 ;;; these should be valid "WORDS", according to CLHS 19.3.1.
210 ;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be
212 (with-test (:name
(:logical-pathname
8))
214 ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE
215 (declare (optimize safety
))
217 (assert (not (ignore-errors
218 (make-pathname :host
"FOO" :directory
"!bla" :name
"bar"))))
220 ;; error: name-component not valid
221 (assert (not (ignore-errors
222 (make-pathname :host
"FOO" :directory
"bla" :name
"!bar"))))
224 ;; error: type-component not valid.
225 (assert (not (ignore-errors
226 (make-pathname :host
"FOO" :directory
"bla" :name
"bar"
229 ;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The
230 ;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC
231 ;;; without actually requiring the system to signal an error (apart
232 ;;; from host mismatches).
233 (with-test (:name
(:logical-pathname
9))
234 (assert (equal (namestring (parse-namestring "" "FOO")) "FOO:"))
235 (assert (equal (namestring (parse-namestring "" :unspecific
)) "")))
237 ;;; The third would work if the call were (and it should continue to
239 (with-test (:name
(:logical-pathname
10))
242 (translate-logical-pathname
245 ;;; ANSI says PARSE-NAMESTRING returns TYPE-ERROR on host mismatch.
246 (with-test (:name
(:logical-pathname
11))
247 (let ((cond (grab-condition (parse-namestring "foo:jeamland" "demo2"))))
248 (assert (typep cond
'type-error
))))
250 ;;; turning one logical pathname into another:
251 (with-test (:name
(:logical-pathname
12))
252 (setf (logical-pathname-translations "foo")
253 '(("todemo;*.*.*" "demo0:*.*.*")))
254 (assert (equal (namestring (translate-logical-pathname "foo:todemo;x.y"))
255 (namestring (translate-logical-pathname "demo0:x.y")))))
257 ;;; ANSI, in its wisdom, specifies that it's an error (specifically a
258 ;;; TYPE-ERROR) to query the system about the translations of a string
259 ;;; which doesn't have any translations. It's not clear why we don't
260 ;;; just return NIL in that case, but they make the rules..
261 (with-test (:name
(:logical-pathname
13))
262 (let ((cond (grab-condition (logical-pathname-translations "unregistered-host"))))
263 (assert (typep cond
'type-error
)))
265 (assert (not (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST")))
266 (assert (string-equal (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN")))
268 ;;; FIXME: A comment on this section up to sbcl-0.6.11.30 or so said
269 ;;; examples from CLHS: Section 19.4, LOGICAL-PATHNAME-TRANSLATIONS
270 ;;; (sometimes converted to the Un*x way of things)
271 ;;; but when I looked it up I didn't see the connection. Presumably
272 ;;; there's some code in this section which should be attributed
273 ;;; to something in the ANSI spec, but I don't know what code it is
274 ;;; or what section of the specification has the related code.
275 (with-test (:name
(:logical-pathname
14))
276 (setf (logical-pathname-translations "test0")
277 '(("**;*.*.*" "/library/foo/**/")))
278 (assert (equal (namestring (translate-logical-pathname
279 "test0:foo;bar;baz;mum.quux"))
280 "/library/foo/foo/bar/baz/mum.quux"))
281 (setf (logical-pathname-translations "prog")
282 '(("RELEASED;*.*.*" "MY-UNIX:/sys/bin/my-prog/")
283 ("RELEASED;*;*.*.*" "MY-UNIX:/sys/bin/my-prog/*/")
284 ("EXPERIMENTAL;*.*.*" "MY-UNIX:/usr/Joe/development/prog/")
285 ("EXPERIMENTAL;*;*.*.*" "MY-UNIX:/usr/Joe/development/prog/*/")))
286 (setf (logical-pathname-translations "prog")
287 '(("CODE;*.*.*" "/lib/prog/")))
288 (assert (equal (namestring (translate-logical-pathname
289 "prog:code;documentation.lisp"))
290 "/lib/prog/documentation.lisp"))
291 (setf (logical-pathname-translations "prog")
292 '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
293 ("CODE;*.*.*" "/lib/prog/")))
294 (assert (equal (namestring (translate-logical-pathname
295 "prog:code;documentation.lisp"))
296 "/lib/prog/docum.lisp")))
298 ;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem
299 ;;; which doesn't have versions should ignore the version slot. CMU CL
300 ;;; didn't ignore this as it should, but we do.
301 (with-test (:name
(:logical-pathname
15))
302 (assert (equal (namestring (translate-logical-pathname
303 "test0:foo;bar;baz;mum.quux.3"))
304 "/library/foo/foo/bar/baz/mum.quux")))
307 ;;;; MERGE-PATHNAME tests
309 ;;;; There are some things we don't bother testing, just because they're
310 ;;;; not meaningful on the underlying filesystem anyway.
312 ;;;; Mostly that means that we don't do devices, we don't do versions
313 ;;;; except minimally in LPNs (they get lost in the translation to
314 ;;;; physical hosts, so it's not much of an issue), and we don't do
315 ;;;; hosts except for LPN hosts
317 ;;;; Although these tests could conceivably be useful in principle for
318 ;;;; other implementations, they depend quite heavily on the rules for
319 ;;;; namestring parsing, which are implementation-specific. So, success
320 ;;;; or failure in these tests doesn't tell you anything about
321 ;;;; ANSI-compliance unless your PARSE-NAMESTRING works like ours.
323 ;;; Needs to be done at compile time, so that the #p"" read-macro
324 ;;; correctly parses things as logical pathnames. This is not a
325 ;;; problem as was, as this is an impure file and so gets loaded in,
326 ;;; but just for future proofing...
327 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
328 (setf (logical-pathname-translations "scratch")
329 '(("**;*.*.*" "/usr/local/doc/**/*"))))
331 (with-test (:name
(merge-pathnames 1))
332 (loop for
(expected-result . params
) in
334 (#P
"/usr/local/doc/foo" #p
"foo" #p
"/usr/local/doc/")
335 ;; If pathname does not specify a host, device, directory,
336 ;; name, or type, each such component is copied from
338 ;; 1) no name, no type
339 (#p
"/supplied-dir/name.type" #p
"/supplied-dir/" #p
"/dir/name.type")
340 ;; 2) no directory, no type
341 (#p
"/dir/supplied-name.type" #p
"supplied-name" #p
"/dir/name.type")
342 ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed
344 (#p
"/dir/name.supplied-type"
345 ,(make-pathname :type
"supplied-type")
347 ;; If (pathname-directory pathname) is a list whose car is
348 ;; :relative, and (pathname-directory default-pathname) is a
349 ;; list, then the merged directory is [...]
350 (#p
"/aaa/bbb/ccc/ddd/qqq/www" #p
"qqq/www" #p
"/aaa/bbb/ccc/ddd/eee")
351 ;; except that if the resulting list contains a string or
352 ;; :wild immediately followed by :back, both of them are
354 (#P
"/aaa/bbb/ccc/blah/eee"
355 ;; "../" in a namestring is parsed as :up not :back, so make-pathname
356 ,(make-pathname :directory
'(:relative
:back
"blah"))
357 #p
"/aaa/bbb/ccc/ddd/eee")
358 ;; If (pathname-directory default-pathname) is not a list or
359 ;; (pathname-directory pathname) is not a list whose car is
360 ;; :relative, the merged directory is (or (pathname-directory
361 ;; pathname) (pathname-directory default-pathname))
362 (#P
"/absolute/path/name.type"
363 #p
"/absolute/path/name"
364 #p
"/dir/default-name.type")
365 ;; === logical pathnames ===
366 ;; recognizes a logical pathname namestring when
367 ;; default-pathname is a logical pathname
368 ;; FIXME: 0.6.12.23 fails this one.
370 ;; And, as it happens, it's right to fail it. Because
371 ;; #p"name1" is read in with the ambient *d-p-d* value, which
372 ;; has a physical (Unix) host; therefore, the host of the
373 ;; default-pathname argument to merge-pathnames is
374 ;; irrelevant. The result is (correctly) different if
375 ;; '#p"name1"' is replaced by "name1", below, though it's
376 ;; still not what one might expect... -- CSR, 2002-05-09
377 #+nil
(#P
"scratch:foo;name1" #p
"name1" #p
"scratch:foo;")
378 ;; or when the namestring begins with the name of a defined
379 ;; logical host followed by a colon [I assume that refers to pathname
380 ;; rather than default-pathname]
381 (#p
"SCRATCH:FOO;NAME2" #p
"scratch:;name2" #p
"scratch:foo;")
382 ;; conduct the previous set of tests again, with a lpn first argument
383 (#P
"SCRATCH:USR;LOCAL;DOC;FOO" #p
"scratch:;foo" #p
"/usr/local/doc/")
384 (#p
"SCRATCH:SUPPLIED-DIR;NAME.TYPE"
385 #p
"scratch:supplied-dir;"
387 (#p
"SCRATCH:DIR;SUPPLIED-NAME.TYPE"
388 #p
"scratch:;supplied-name"
390 (#p
"SCRATCH:DIR;NAME.SUPPLIED-TYPE"
391 ,(make-pathname :host
"scratch" :type
"supplied-type")
393 (#p
"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR"
394 ,(make-pathname :host
"scratch"
395 :directory
'(:relative
"foo")
397 #p
"/aaa/bbb/ccc/ddd/eee")
398 (#p
"SCRATCH:AAA;BBB;CCC;FOO;BAR"
399 ,(make-pathname :host
"scratch"
400 :directory
'(:relative
:back
"foo")
402 #p
"/aaa/bbb/ccc/ddd/eee")
403 (#p
"SCRATCH:ABSOLUTE;PATH;NAME.TYPE"
404 #p
"scratch:absolute;path;name" #p
"/dir/default-name.type")
406 ;; FIXME: test version handling in LPNs
408 do
(let ((result (apply #'merge-pathnames params
)))
409 (macrolet ((frob (op)
410 `(assert (equal (,op result
) (,op expected-result
)))))
412 (frob pathname-directory
)
414 (frob pathname-type
)))))
416 ;;; host-namestring testing
417 (with-test (:name host-namestring
)
419 (namestring (parse-namestring "/foo" (host-namestring #p
"/bar")))
422 (namestring (parse-namestring "FOO" (host-namestring #p
"SCRATCH:BAR")))
425 (setf (logical-pathname-translations "")
426 (list '("**;*.*.*" "/**/*.*")))))
428 ;;; Bug 200: translate-logical-pathname is according to the spec supposed
429 ;;; not to give errors if asked to translate a namestring for a valid
430 ;;; physical pathname. Failed in 0.7.7.28 and before
431 (with-test (:name
(:logical-pathname
16))
432 (assert (string= (namestring (translate-logical-pathname "/")) "/")))
435 ;;; Not strictly pathname logic testing, but until sbcl-0.7.6.19 we
436 ;;; had difficulty with non-FILE-STREAM stream arguments to pathname
437 ;;; functions (they would cause memory protection errors). Make sure
438 ;;; that those errors are gone:
439 (with-test (:name
(string-stream :not-a pathname
))
441 (multiple-value-bind (fun failurep warnings
)
443 `(lambda () ,form
) :allow-warnings
'sb-int
:type-warning
)
444 (declare (ignore failurep
))
445 (assert (= 1 (length warnings
)))
446 (assert-error (funcall fun
) type-error
))))
447 (test '(pathname (make-string-input-stream "FOO")))
448 (test '(merge-pathnames (make-string-output-stream)))))
450 ;;; ensure print-read consistency (or print-not-readable-error) on
452 (with-test (:name
:print
/read-consistency
)
453 (dolist (p (list (make-pathname :name
"foo" :type
"txt" :version
:newest
)
454 (make-pathname :name
"foo" :type
"txt" :version
1)
455 (make-pathname :name
"foo" :type
".txt")
456 (make-pathname :name
"foo." :type
"txt")
457 (make-pathname :name
#-win32
"\\" #+win32
"^^" :type
"txt")
458 (make-pathname :name
"^" :type
"txt")
459 (make-pathname :name
"foo*" :type
"txt")
460 (make-pathname :name
"foo[" :type
"txt")
461 (parse-namestring "SCRATCH:FOO.TXT.1")
462 (parse-namestring "SCRATCH:FOO.TXT.NEWEST")
463 (parse-namestring "SCRATCH:FOO.TXT")))
465 (let* ((*print-readably
* t
)
466 (new (read-from-string (format nil
"~S" p
))))
467 (unless (equal new p
)
468 (let ((*print-readably
* nil
))
469 (error "oops: host:~S device:~S dir:~S version:~S~% ->~%~
470 host:~S device:~S dir:~S version:~S"
471 (pathname-host p
) (pathname-device p
)
472 (pathname-directory p
) (pathname-version p
)
473 (pathname-host new
) (pathname-device new
)
474 (pathname-directory new
) (pathname-version new
)))))
475 (print-not-readable ()
478 ;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the
479 ;;; default argument" ...and streams as well
480 (with-test (:name
(parse-namestring stream
))
481 (assert (equal (parse-namestring "foo" nil
"/")
482 (parse-namestring "foo" nil
#P
"/")))
483 (let ((test "parse-namestring-test.tmp"))
485 (with-open-file (f test
:direction
:output
)
486 ;; FIXME: This test is a bit flaky, since we only check that
487 ;; no error is signalled. The dilemma here is "what is the
488 ;; correct result when defaults is a _file_, not a
489 ;; directory". Currently (0.8.10.73) we get #P"foo" here (as
490 ;; opposed to eg. #P"/path/to/current/foo"), which is
491 ;; possibly mildly surprising but probably conformant.
492 (assert (parse-namestring "foo" nil f
)))
493 (when (probe-file test
)
494 (delete-file test
)))))
496 ;;; ENOUGH-NAMESTRING should probably not fail when the namestring in
497 ;;; question has a :RELATIVE pathname.
498 (with-test (:name enough-namestring
)
499 (assert (equal (enough-namestring #p
"foo" #p
"./") "foo")))
503 ;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing
504 ;;; directory lists. lp#1738775, reported by Richard M. Kreuter, added
506 (with-test (:name
(namestring :wild
:wild-inferiors
:up
:lp-1738775
))
507 (flet ((test (expected pathname
)
508 (assert (equal (namestring pathname
) expected
))))
509 ;; The second variant using MAKE-PATHNAME makes sure we don't just
510 ;; return the original namestring.
511 (test "/tmp/*/" #P
"/tmp/*/")
512 (test "/tmp/*/" (make-pathname :directory
'(:absolute
"tmp" :wild
)))
514 ;; lp#1738775 reported breakage in case FIRST in (:absolute FIRST
515 ;; ...) is not of type STRING.
517 (test "/*/" (make-pathname :directory
'(:absolute
:wild
)))
519 (test "/**/" #P
"/**/")
520 (test "/**/" (make-pathname :directory
'(:absolute
:wild-inferiors
)))
522 ;; FIXME "Invalid combinations" in 19.2.2.4.3 requires :ABSOLUTE
523 ;; :UP to signal a FILE-ERROR, but we don't.
524 (test "/../" #P
"/../")
525 (test "/../" (make-pathname :directory
'(:absolute
:up
)))))
527 (with-test (:name
(namestring :escape-pattern-pieces
))
528 (labels ((prepare (namestring)
529 #-win32
(substitute #\\ #\E namestring
)
530 #+win32
(substitute #\^
#\E namestring
))
531 (test (expected namestring
)
532 (let ((pathname (pathname (prepare namestring
))))
533 (assert (string= (prepare expected
) (namestring pathname
))))))
534 #-win32
(test "*E?" "*E?")
535 #-win32
(test "*E*" "*E*")
536 (test "*E[ab]" "*E[ab]")
539 ;;; Printing of pathnames; see CLHS 22.1.3.1. This section was started
540 ;;; to confirm that pathnames are printed as their namestrings under
541 ;;; :escape nil :readably nil.
542 (with-test (:name
:print-as-namestrings
)
543 (loop for
(pathname expected . vars
) in
544 `((#p
"/foo" "#P\"/foo\"")
545 (#p
"/foo" "#P\"/foo\"" :readably nil
)
546 (#p
"/foo" "#P\"/foo\"" :escape nil
)
547 (#p
"/foo" "/foo" :readably nil
:escape nil
))
548 for actual
= (with-standard-io-syntax
549 (apply #'write-to-string pathname vars
))
550 do
(assert (string= expected actual
)
552 "~S should be ~S, was ~S"
553 (list* 'write-to-string pathname vars
)
557 ;;; we got (truename "/") wrong for about 6 months. Check that it's
559 (with-test (:name
:root-truename
)
560 (let ((pathname (truename "/")))
561 (assert (equalp pathname
(merge-pathnames #p
"/")))
562 (assert (equal (pathname-directory pathname
) '(:absolute
)))))
564 ;;; we failed to unparse logical pathnames with :NAME :WILD :TYPE NIL.
565 ;;; (Reported by Pascal Bourguignon.
566 (with-test (:name
(namestring :unparse-logical-wild
))
567 (let ((pathname (make-pathname :host
"SYS" :directory
'(:absolute
:wild-inferiors
)
568 :name
:wild
:type nil
)))
569 (assert (string= (namestring pathname
) "SYS:**;*"))
570 (assert (string= (write-to-string pathname
:readably t
) "#P\"SYS:**;*\""))))
572 (with-test (:name
(namestring :signals file-error
))
573 (flet ((test (&rest initargs
)
574 (let ((pathname (apply #'make-pathname initargs
)))
575 (assert-error (namestring pathname
) file-error
))))
579 (test :name
"foo" :type
".bar")))
581 ;;; reported by James Y Knight on sbcl-devel 2006-05-17
582 (with-test (:name
:merge-back
)
583 (let ((p1 (make-pathname :directory
'(:relative
"bar")))
584 (p2 (make-pathname :directory
'(:relative
:back
"foo"))))
585 (assert (equal (merge-pathnames p1 p2
)
586 (make-pathname :directory
'(:relative
:back
"foo" "bar"))))))
588 (with-test (:name
(native-namestring :signals file-error
:unix
))
589 (flet ((test (&rest initargs
)
590 (let ((pathname (apply #'make-pathname initargs
)))
591 (assert-error (native-namestring pathname
) file-error
))))
592 (test :directory
'(:absolute
(:home
"no-such-user")))
593 (test :directory
'(:absolute
:wild
))
595 (test :name
"foo" :type
:wild
)
598 ;;; construct native namestrings even if the directory is empty (means
599 ;;; that same as if (:relative))
600 (with-test (:name
(sb-ext:native-namestring
1))
601 (assert (equal (sb-ext:native-namestring
(make-pathname :directory
'(:relative
)
604 (sb-ext:native-namestring
(let ((p (make-pathname :directory nil
607 (assert (not (pathname-directory p
)))
610 ;;; reported by Richard Kreuter: PATHNAME and MERGE-PATHNAMES used to
611 ;;; be unsafely-flushable. Since they are known to return non-nil values
612 ;;; only, the test-node of the IF is flushed, and since the function
613 ;;; is unsafely-flushable, out it goes, and bad pathname designators
616 ;;; These tests rely on using a stream that appears as a file-stream
617 ;;; but isn't a valid pathname-designator.
618 (with-test (:name
:dont-flush-pathnames
)
620 (if (ignore-errors (pathname sb-sys
::*tty
*)) :true
:false
)))
622 (if (ignore-errors (merge-pathnames sb-sys
::*tty
*)) :true
:false
))))
624 ;;; This used to return "quux/bar.lisp"
625 (with-test (:name
:dpd-output-file
)
626 (assert (equal #p
"quux/bar.fasl"
627 (let ((*default-pathname-defaults
* #p
"quux/"))
628 (compile-file-pathname "foo.lisp" :output-file
"bar"))))
629 (assert (equal #p
"quux/bar.fasl"
630 (let ((*default-pathname-defaults
* #p
"quux/"))
631 (compile-file-pathname "bar.lisp")))))
633 (with-test (:name
:wild-enough
)
634 (enough-namestring #p
".a*"))
637 (with-test (:name
:translated-wild-version
)
641 (make-pathname :name
"foo" :type
"bar" :version
99)
642 (make-pathname :name
:wild
:type
:wild
:version
:wild
)
643 (make-pathname :name
:wild
:type
:wild
:version
:wild
)))))
648 (make-pathname :name
"foo" :type
"bar" :version
99)
649 (make-pathname :name
:wild
:type
:wild
:version
:wild
)
650 (make-pathname :name
:wild
:type
:wild
:version nil
))))))
652 ;;; enough-namestring relative to root
653 (with-test (:name
:enough-relative-to-root
)
654 (assert (equal "foo" (enough-namestring "/foo" "/"))))
656 ;;; Check the handling of NIL, :UNSPECIFIC, the empty string, and
657 ;;; non-NIL strings in NATIVE-NAMESTRING implementations. Revised by
658 ;;; RMK 2007-11-28, attempting to preserve the apparent intended
659 ;;; denotation of SBCL's then-current pathname implementation.
660 (with-test (:name
(sb-ext:native-namestring
2))
662 (loop with components
= (list nil
:unspecific
"" "a")
663 for name in components
664 appending
(loop for type in components
665 as pathname
= (make-pathname
666 #+win32
:device
#+win32
"C"
667 :directory
'(:absolute
"tmp")
668 :name name
:type type
)
669 collect
(ignore-errors
670 (sb-ext:native-namestring pathname
))))
672 #|type NIL
:UNSPECIFIC
"" "a" |
#
674 #|NIL |
# '("/tmp/" "/tmp/" NIL NIL
675 #|
:UNSPECIFIC|
# "/tmp/" "/tmp/" NIL NIL
676 #|
"" |
# "/tmp/" "/tmp/" "/tmp/." "/tmp/.a"
677 #|
"a" |
# "/tmp/a" "/tmp/a" "/tmp/a." "/tmp/a.a")
680 #|type NIL
:UNSPECIFIC
"" "a" |
#
682 #|NIL |
# '("C:\\tmp\\" "C:\\tmp\\" NIL NIL
683 #|
:UNSPECIFIC|
# "C:\\tmp\\" "C:\\tmp\\" NIL NIL
684 #|
"" |
# "C:\\tmp\\" "C:\\tmp\\" "C:\\tmp\\." "C:\\tmp\\.a"
685 #|
"a" |
# "C:\\tmp\\a" "C:\\tmp\\a" "C:\\tmp\\a." "C:\\tmp\\a.a"))))
687 (with-test (:name
(delete-file logical-pathname
))
688 (setf (logical-pathname-translations "SB-TEST")
689 (list (list "**;*.*.*" (make-pathname :name
:wild
691 :defaults
(truename ".")))))
692 (let ((test (pathname "SB-TEST:delete-logical-pathname.tmp")))
693 (assert (typep test
'logical-pathname
))
694 (with-open-file (f test
:direction
:output
)
695 (write-line "delete me!" f
))
696 (assert (probe-file test
))
697 (assert (delete-file test
))
698 (assert (not (probe-file test
)))))
700 ;;; Reported by Willem Broekema: Reading #p"\\\\" caused an error due
701 ;;; to insufficient sanity in input testing in EXTRACT-DEVICE (in
702 ;;; src;code;win32-pathname).
703 (with-test (:name
:bug-489698
:skipped-on
(not :win32
))
704 (assert (equal (make-pathname :directory
'(:absolute
))
705 (read-from-string "#p\"\\\\\\\\\""))))
707 (with-test (:name
:load-logical-pathname-translations
)
708 (let* ((cwd (truename "."))
709 (foo (merge-pathnames "llpnt-foo.translations" cwd
))
710 (bar (merge-pathnames "llpnt-bar.translations" cwd
))
711 (translations (logical-pathname-translations "SYS")))
714 (with-open-file (f foo
:direction
:output
)
715 (prin1 (list (list "*.TEXT" (make-pathname
716 :directory
'(:absolute
"my" "foo")
717 :name
:wild
:type
"txt")))
719 (with-open-file (f bar
:direction
:output
)
720 (prin1 (list (list "*.CL" (make-pathname
721 :directory
'(:absolute
"my" "bar")
722 :name
:wild
:type
"lisp"))) f
))
723 (setf (logical-pathname-translations "SYS")
724 (list* (list "SITE;LLPNT-FOO.TRANSLATIONS.NEWEST" foo
)
725 (list "SITE;LLPNT-BAR.TRANSLATIONS.NEWEST" bar
)
727 (assert (load-logical-pathname-translations "LLPNT-FOO"))
728 (assert (load-logical-pathname-translations "LLPNT-BAR"))
731 (equal "/my/bar/quux.lisp"
732 (namestring (translate-logical-pathname "LLPNT-BAR:QUUX.CL")))
733 (equal "/my/foo/quux.txt"
734 (namestring (translate-logical-pathname "LLPNT-FOO:QUUX.TEXT"))))))
735 (ignore-errors (delete-file foo
))
736 (ignore-errors (delete-file bar
))
737 (setf (logical-pathname-translations "SYS") translations
))))
739 (with-test (:name
:tilde-expansion
)
740 (assert (equal '(:absolute
:home
"foo") (pathname-directory "~/foo/bar.txt")))
741 (assert (equal '(:absolute
(:home
"jdoe") "quux") (pathname-directory "~jdoe/quux/")))
742 (assert (equal "~/foo/x" (namestring (make-pathname :directory
'(:absolute
:home
"foo")
744 (assert (equal (native-namestring (merge-pathnames "a/b.c" (user-homedir-pathname)))
745 (native-namestring #p
"~/a/b.c")))
747 (assert (equal (native-namestring #p
"~foo") "~foo"))
748 ;; Not at the start of the first directory
749 (assert (equal (native-namestring #p
"foo/~/bar")
751 #+win32
"foo\\~\\bar"))
752 (equal (native-namestring (merge-pathnames "~/"))
753 (native-namestring (user-homedir-pathname))))
756 (with-test (:name
:pathname-escape-first-directory-component
759 (assert (equal (pathname-directory #-win32
#p
"\\~/foo/"
761 '(:relative
"~" "foo")))
762 (assert (equal (native-namestring #-win32
#p
"\\~/foo/"
766 (assert (equal (namestring (make-pathname :directory
'(:absolute
"~zot")))
769 (assert (equal (pathname-directory #p
"\\*/") '(:relative
"*"))))
771 (with-test (:name
(ensure-directories-exist :with-odd-d-p-d
))
772 (let ((*default-pathname-defaults
* #p
"/tmp/foo"))
773 (ensure-directories-exist "/")))
775 (with-test (:name
:long-file-name
:skipped-on
(not :win32
))
776 (let* ((x '("hint--if-you-are-having-trouble-deleting-this-test-directory"
777 "use-the-7zip-file-manager"))
779 (directory-namestring (or *load-pathname
* *compile-file-pathname
*))))
780 (shallow (make-pathname :directory
`(:relative
,(car x
))))
781 (shallow (merge-pathnames shallow base
))
783 :directory
`(:relative
,@(loop repeat
10 appending x
))))
784 (deep (merge-pathnames deep base
))
785 (native (sb-ext:native-namestring deep
)))
786 (assert (> (length native
) 260))
787 (assert (eql 3 (mismatch "\\\\?" native
)))
788 (assert (not (probe-file shallow
)))
791 (ensure-directories-exist deep
)
792 (assert (probe-file deep
)))
793 (sb-ext:delete-directory shallow
:recursive t
))
794 (assert (not (probe-file shallow
)))))
797 (with-test (:name sb-int
:simplify-namestring
)
798 (assert (string= (sb-int:simplify-namestring
"./a/b/../c/")
801 (with-test (:name
:back-and-truename
)
802 (probe-file (make-pathname :directory
'(:absolute
"a" "b" :back
))))
804 (with-test (:name
(parse-namestring :displaced
))
805 (let* ((string "abc")
806 (disp (make-array 0 :element-type
(array-element-type string
)
808 :displaced-index-offset
1)))
809 (multiple-value-bind (path pos
)
810 (parse-namestring disp
)
811 (assert (equal path
#P
""))
812 (assert (zerop pos
)))))
814 (with-test (:name
(sb-ext:parse-native-namestring
:displaced
))
815 (let* ((string "abc")
816 (disp (make-array 0 :element-type
(array-element-type string
)
818 :displaced-index-offset
1)))
819 (multiple-value-bind (path pos
)
820 (sb-ext:parse-native-namestring disp
)
821 (assert (equal path
#P
""))
822 (assert (zerop pos
)))))
824 (with-test (:name
(:parse-logical-pathname
:displaced
))
825 (let* ((string "XSYS:ABC.LISP")
826 (disp (make-array (1- (length string
))
827 :element-type
(array-element-type string
)
829 :displaced-index-offset
1)))
830 (assert (equal (parse-namestring disp
) #p
"SYS:ABC.LISP"))))