1(define-library (chibi pathname-test)
2  (export run-tests)
3  (import (scheme base) (chibi pathname) (chibi test))
4  (begin
5    (define (run-tests)
6      (test-begin "pathname")
7
8      ;; tests from the dirname(3) manpage
9
10      (test "dirname(3)" "/usr" (path-directory "/usr/lib"))
11      (test "lib"  (path-strip-directory "/usr/lib"))
12
13      (test "/"    (path-directory "/usr/"))
14      (test ""     (path-strip-directory "/usr/"))
15
16      (test "."    (path-directory "usr"))
17      (test "usr"  (path-strip-directory "usr"))
18
19      (test "/"    (path-directory "/"))
20      (test ""     (path-strip-directory "/"))
21
22      (test "."    (path-directory "."))
23      (test "."    (path-strip-directory "."))
24
25      (test "."    (path-directory ".."))
26      (test ".."   (path-strip-directory ".."))
27
28      ;; additional tests (should match GNU dirname/basename behavior)
29
30      (test "path-directory:border"
31          "/"    (path-directory "//"))
32      (test ""     (path-strip-directory "//"))
33
34      (test "."    (path-directory ""))
35      (test ""     (path-strip-directory ""))
36
37      (test "."    (path-directory "../"))
38      (test ""     (path-strip-directory "../"))
39
40      (test ".."   (path-directory "../.."))
41      (test ".."   (path-strip-directory "../.."))
42
43      (test "path-directory:extra"
44          "/usr/local" (path-directory "/usr/local/lib"))
45      (test "lib" (path-strip-directory "/usr/local/lib"))
46
47      (test "/usr" (path-directory "/usr/local/"))
48      (test "" (path-strip-directory "/usr/local/"))
49
50      (test "usr"    (path-directory "usr/local"))
51      (test "local"  (path-strip-directory "usr/local"))
52
53      (test "/" (path-directory "//usr"))
54      (test "usr" (path-strip-directory "//usr"))
55
56      (test "/" (path-directory "//usr/"))
57      (test "" (path-strip-directory "//usr/"))
58
59      (test "path-directory:small"
60          "/a" (path-directory "/a/b"))
61      (test "b" (path-strip-directory "/a/b"))
62
63      (test "a" (path-directory "a/b"))
64      (test "b" (path-strip-directory "a/b"))
65
66      (test "a" (path-directory "a/b/"))
67      (test "" (path-strip-directory "a/b/"))
68
69      (test "/a/b/c" (path-directory "/a/b/c/d"))
70      (test "d" (path-strip-directory "/a/b/c/d"))
71
72      (test "/a/b/c" (path-directory "/a/b/c/d/"))
73      (test "" (path-strip-directory "/a/b/c/d/"))
74
75      (test "a/b/c"    (path-directory "a/b/c/d"))
76      (test "d"  (path-strip-directory "a/b/c/d"))
77
78      (test "/a/b" (path-directory "/a/b/c.d"))
79      (test "c.d" (path-strip-directory "/a/b/c.d"))
80
81      (test "/a/b" (path-directory "/a/b/c.d/"))
82      (test "" (path-strip-directory "/a/b/c.d/"))
83
84      (test "/a/b/c" (path-directory "/a/b/c/."))
85      (test "." (path-strip-directory "/a/b/c/."))
86
87      (test "/a/b/c" (path-directory "/a/b/c/.."))
88      (test ".." (path-strip-directory "/a/b/c/.."))
89
90      (test "/a/b/." (path-directory "/a/b/./c"))
91      (test "c" (path-strip-directory "/a/b/./c"))
92
93      (test "/a/b/.." (path-directory "/a/b/../c"))
94      (test "c" (path-strip-directory "/a/b/../c"))
95
96      (test "/a/b" (path-directory "/a/b/c//"))
97      (test "" (path-strip-directory "/a/b/c//"))
98
99      (test "/a/b" (path-directory "/a/b//c///"))
100      (test "" (path-strip-directory "/a/b//c///"))
101
102      ;; extensions
103
104      (test "path-extension" "scm" (path-extension "foo.scm"))
105      (test "foo" (path-strip-extension "foo.scm"))
106
107      (test "c" (path-extension "foo.scm.c"))
108      (test "foo.scm" (path-strip-extension "foo.scm.c"))
109
110      (test "scm" (path-extension "/home/me/foo.scm"))
111      (test "/home/me/foo" (path-strip-extension "/home/me/foo.scm"))
112
113      (test "scm" (path-extension "foo..scm"))
114      (test "foo." (path-strip-extension "foo..scm"))
115
116      (test "s" (path-extension "foo.s"))
117      (test "foo" (path-strip-extension "foo.s"))
118
119      (test #f (path-extension "foo."))
120      (test "foo." (path-strip-extension "foo."))
121
122      (test #f (path-extension "foo.scm."))
123      (test "foo.scm." (path-strip-extension "foo.scm."))
124
125      (test #f (path-extension "."))
126      (test "." (path-strip-extension "."))
127
128      (test #f (path-extension "a."))
129      (test "a." (path-strip-extension "a."))
130
131      (test #f (path-extension "/."))
132      (test "/." (path-strip-extension "/."))
133
134      (test #f (path-extension "foo.scm/"))
135      (test "foo.scm/" (path-strip-extension "foo.scm/"))
136
137      (test "path-replace-extension"
138          "foo.c" (path-replace-extension "foo.scm" "c"))
139      (test "foo.c" (path-replace-extension "foo" "c"))
140
141      ;; absolute paths
142
143      (test-assert (path-absolute? "/"))
144      (test-assert (path-absolute? "//"))
145      (test-assert (path-absolute? "/usr"))
146      (test-assert (path-absolute? "/usr/"))
147      (test-assert (path-absolute? "/usr/."))
148      (test-assert (path-absolute? "/usr/.."))
149      (test-assert (path-absolute? "/usr/./"))
150      (test-assert (path-absolute? "/usr/../"))
151
152      (test-assert (not (path-absolute? "")))
153      (test-assert (not (path-absolute? ".")))
154      (test-assert (not (path-absolute? "usr")))
155      (test-assert (not (path-absolute? "usr/")))
156
157      ;; normalization & building
158
159      (test "path-normalize" "/a/b/c/d/e" (path-normalize "/a/b/c/d/./e"))
160      (test "/a/b/c/d/e" (path-normalize "/a/b//.///c//d/./e"))
161      (test "/a/b/c/d/e/" (path-normalize "/a/b//.///c//d/./e/"))
162      (test "/a/c/d/e" (path-normalize "/a/b/../c/d/e"))
163      (test "/a/b/c/e" (path-normalize "/a/b//.///c//d/../e"))
164      (test "/a/c/e" (path-normalize "/a/b//..///c//d/../e"))
165      (test "/a/b/c/d/e/"
166          (path-normalize "/a/b//./../c/d/../../b//c/d/e/f/.."))
167      (test "/a/b/c/" (path-normalize "/a/b/c/."))
168
169      (test "path-normalize:border" "" (path-normalize ""))
170      (test "." (path-normalize "."))
171      (test "/" (path-normalize "/"))
172      (test "/" (path-normalize "/."))
173
174      (test "path-normalize:overflow"
175          "/" (path-normalize "/a/b/c/../../../../.."))
176      (test "../.." (path-normalize "a/b/c/../../../../.."))
177      (test "../../.." (path-normalize "../a/b/c/../../../../.."))
178
179      (test "" (path-strip-leading-parents ".."))
180      (test "" (path-strip-leading-parents "../"))
181      (test "a" (path-strip-leading-parents "../a"))
182      (test "a/b" (path-strip-leading-parents "../../a/b"))
183      (test "a/b" (path-strip-leading-parents "../../../a/b"))
184      (test "a/../b" (path-strip-leading-parents "../../../a/../b"))
185
186      (test "path-relative-to" "c" (path-relative-to "/a/b/c" "/a/b"))
187      (test "c" (path-relative-to "/a/b/c" "/a/b/"))
188      (test "." (path-relative-to "/a/b/" "/a/b/"))
189      (test "." (path-relative-to "/a/b/" "/a/b"))
190      (test "." (path-relative-to "/a/b" "/a/b/"))
191      (test "." (path-relative-to "/a/b" "/a/b"))
192      (test-not (path-relative-to "/d/a/b/c" "/a/b"))
193
194      (test "make-path" "a/b" (make-path "a" "b"))
195      (test "a/b" (make-path "a/" "b"))
196      (test "a/b/./c" (make-path "a" "b" "." "c"))
197      (test "a/b/../c" (make-path "a" "b" ".." "c"))
198      (test "a/b/c" (make-path "a" '("b" "c")))
199      (test "/" (make-path "/" ""))
200      (test "/" (make-path "/" "/"))
201      (test "/." (make-path "/" "."))
202      (test "/a" (make-path "/a" ""))
203      (test "/a" (make-path "/a" "/"))
204      (test "/a/." (make-path "/a" "."))
205
206      (test-end))))
207