Commit | Line | Data |
---|---|---|
8ab3d8a0 KR |
1 | ;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*- |
2 | ;;;; | |
be96155b | 3 | ;;;; Copyright 2006, 2011, 2012 Free Software Foundation, Inc. |
8ab3d8a0 KR |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
8ab3d8a0 KR |
9 | ;;;; |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | (define-module (test-suite test-ice-9-ftw) | |
20 | #:use-module (test-suite lib) | |
243db01e LC |
21 | #:use-module (ice-9 ftw) |
22 | #:use-module (ice-9 match) | |
23 | #:use-module (srfi srfi-1) | |
24 | #:use-module (srfi srfi-26)) | |
8ab3d8a0 KR |
25 | |
26 | ||
27 | ;; the procedure-source checks here ensure the vector indexes we write match | |
28 | ;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match | |
29 | ;; libguile/filesys.c of course) | |
30 | ||
8ab3d8a0 KR |
31 | (define (stat:dev! st dev) |
32 | (vector-set! st 0 dev)) | |
8ab3d8a0 KR |
33 | (define (stat:ino! st ino) |
34 | (vector-set! st 1 ino)) | |
35 | ||
7ff01700 AW |
36 | (let* ((s (stat "/")) |
37 | (i (stat:ino s)) | |
38 | (d (stat:dev s))) | |
39 | (stat:ino! s (1+ i)) | |
40 | (stat:dev! s (1+ d)) | |
41 | (if (not (and (= (stat:ino s) (1+ i)) | |
42 | (= (stat:dev s) (1+ d)))) | |
43 | (error "unexpected definitions of stat:dev and stat:ino"))) | |
8ab3d8a0 KR |
44 | |
45 | ;; | |
46 | ;; visited?-proc | |
47 | ;; | |
48 | ||
49 | (with-test-prefix "visited?-proc" | |
50 | ||
51 | ;; normally internal-only | |
52 | (let* ((visited?-proc (@@ (ice-9 ftw) visited?-proc)) | |
53 | (visited? (visited?-proc 97)) | |
54 | (s (stat "/"))) | |
55 | ||
56 | (define (try-visited? dev ino) | |
57 | (stat:dev! s dev) | |
58 | (stat:ino! s ino) | |
59 | (visited? s)) | |
60 | ||
61 | (pass-if "0 0 - 1st" (eq? #f (try-visited? 0 0))) | |
62 | (pass-if "0 0 - 2nd" (eq? #t (try-visited? 0 0))) | |
63 | (pass-if "0 0 - 3rd" (eq? #t (try-visited? 0 0))) | |
64 | ||
65 | (pass-if "0 1" (eq? #f (try-visited? 0 1))) | |
66 | (pass-if "0 2" (eq? #f (try-visited? 0 2))) | |
67 | (pass-if "0 3" (eq? #f (try-visited? 0 3))) | |
68 | ||
69 | (pass-if "5 5" (eq? #f (try-visited? 5 5))) | |
70 | (pass-if "5 7" (eq? #f (try-visited? 5 7))) | |
71 | (pass-if "7 5" (eq? #f (try-visited? 7 5))) | |
72 | (pass-if "7 7" (eq? #f (try-visited? 7 7))) | |
73 | ||
74 | (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5))) | |
75 | (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7))) | |
76 | (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5))) | |
77 | (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7))))) | |
243db01e LC |
78 | |
79 | \f | |
80 | ;;; | |
81 | ;;; `file-system-fold' & co. | |
82 | ;;; | |
83 | ||
be96155b LC |
84 | (define %top-builddir |
85 | (canonicalize-path (getcwd))) | |
86 | ||
243db01e LC |
87 | (define %top-srcdir |
88 | (assq-ref %guile-build-info 'top_srcdir)) | |
89 | ||
90 | (define %test-dir | |
91 | (string-append %top-srcdir "/test-suite")) | |
92 | ||
d10f7b57 AW |
93 | (define %test-suite-lib-dir |
94 | (string-append %top-srcdir "/test-suite/test-suite")) | |
95 | ||
be96155b LC |
96 | (define (make-file-tree dir tree) |
97 | "Make file system TREE at DIR." | |
98 | (define (touch file) | |
99 | (call-with-output-file file | |
100 | (cut display "" <>))) | |
101 | ||
102 | (let loop ((dir dir) | |
103 | (tree tree)) | |
104 | (define (scope file) | |
105 | (string-append dir "/" file)) | |
106 | ||
107 | (match tree | |
108 | (('directory name (body ...)) | |
109 | (mkdir (scope name)) | |
110 | (for-each (cute loop (scope name) <>) body)) | |
111 | (('directory name (? integer? mode) (body ...)) | |
112 | (mkdir (scope name)) | |
113 | (for-each (cute loop (scope name) <>) body) | |
114 | (chmod (scope name) mode)) | |
115 | ((file) | |
116 | (touch (scope file))) | |
117 | ((file (? integer? mode)) | |
118 | (touch (scope file)) | |
119 | (chmod (scope file) mode)) | |
120 | ((from '-> to) | |
121 | (symlink to (scope from)))))) | |
122 | ||
123 | (define (delete-file-tree dir tree) | |
124 | "Delete file TREE from DIR." | |
125 | (let loop ((dir dir) | |
126 | (tree tree)) | |
127 | (define (scope file) | |
128 | (string-append dir "/" file)) | |
129 | ||
130 | (match tree | |
131 | (('directory name (body ...)) | |
132 | (for-each (cute loop (scope name) <>) body) | |
133 | (rmdir (scope name))) | |
134 | (('directory name (? integer? mode) (body ...)) | |
135 | (chmod (scope name) #o755) ; make sure it can be entered | |
136 | (for-each (cute loop (scope name) <>) body) | |
137 | (rmdir (scope name))) | |
138 | ((from '-> _) | |
139 | (delete-file (scope from))) | |
140 | ((file _ ...) | |
141 | (delete-file (scope file)))))) | |
142 | ||
143 | (define-syntax-rule (with-file-tree dir tree body ...) | |
144 | (dynamic-wind | |
145 | (lambda () | |
146 | (make-file-tree dir tree)) | |
147 | (lambda () | |
148 | body ...) | |
149 | (lambda () | |
150 | (delete-file-tree dir tree)))) | |
151 | ||
243db01e LC |
152 | (with-test-prefix "file-system-fold" |
153 | ||
154 | (pass-if "test-suite" | |
155 | (let ((enter? (lambda (n s r) | |
156 | ;; Enter only `test-suite/tests/'. | |
157 | (if (member `(down ,%test-dir) r) | |
d10f7b57 AW |
158 | (or (string=? (basename n) "tests") |
159 | (string=? (basename n) "test-suite")) | |
243db01e LC |
160 | (string=? (basename n) "test-suite")))) |
161 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
162 | (down (lambda (n s r) (cons `(down ,n) r))) | |
163 | (up (lambda (n s r) (cons `(up ,n) r))) | |
be96155b LC |
164 | (skip (lambda (n s r) (cons `(skip ,n) r))) |
165 | (error (lambda (n s e r) (cons `(error ,n) r)))) | |
243db01e LC |
166 | (define seq |
167 | (reverse | |
be96155b | 168 | (file-system-fold enter? leaf down up skip error '() %test-dir))) |
243db01e LC |
169 | |
170 | (match seq | |
171 | ((('down (? (cut string=? <> %test-dir))) | |
172 | between ... | |
173 | ('up (? (cut string=? <> %test-dir)))) | |
d10f7b57 | 174 | (and (any (match-lambda (('down (= basename "test-suite")) #t) (_ #f)) |
243db01e LC |
175 | between) |
176 | (any (match-lambda (('down (= basename "tests")) #t) (_ #f)) | |
177 | between) | |
178 | (any (match-lambda (('leaf (= basename "alist.test")) #t) (_ #f)) | |
179 | between) | |
180 | (any (match-lambda (('up (= basename "tests")) #t) (_ #f)) | |
181 | between) | |
182 | (any (match-lambda (('skip (= basename "vm")) #t) (_ #f)) | |
183 | between)))))) | |
184 | ||
f3bb42fc LC |
185 | (pass-if-equal "test-suite (never enter)" |
186 | `((skip ,%test-dir)) | |
243db01e LC |
187 | (let ((enter? (lambda (n s r) #f)) |
188 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
189 | (down (lambda (n s r) (cons `(down ,n) r))) | |
190 | (up (lambda (n s r) (cons `(up ,n) r))) | |
be96155b LC |
191 | (skip (lambda (n s r) (cons `(skip ,n) r))) |
192 | (error (lambda (n s e r) (cons `(error ,n) r)))) | |
f3bb42fc | 193 | (file-system-fold enter? leaf down up skip error '() %test-dir))) |
243db01e | 194 | |
f3bb42fc LC |
195 | (let ((name (string-append %test-suite-lib-dir "/lib.scm"))) |
196 | (pass-if-equal "test-suite/lib.scm (flat file)" | |
197 | `((leaf ,name)) | |
198 | (let ((enter? (lambda (n s r) #t)) | |
199 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
200 | (down (lambda (n s r) (cons `(down ,n) r))) | |
201 | (up (lambda (n s r) (cons `(up ,n) r))) | |
202 | (skip (lambda (n s r) (cons `(skip ,n) r))) | |
203 | (error (lambda (n s e r) (cons `(error ,n) r)))) | |
204 | (file-system-fold enter? leaf down up skip error '() name)))) | |
be96155b LC |
205 | |
206 | (pass-if "ENOENT" | |
207 | (let ((enter? (lambda (n s r) #t)) | |
208 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
209 | (down (lambda (n s r) (cons `(down ,n) r))) | |
210 | (up (lambda (n s r) (cons `(up ,n) r))) | |
211 | (skip (lambda (n s r) (cons `(skip ,n) r))) | |
212 | (error (lambda (n s e r) (cons `(error ,n ,e) r))) | |
213 | (name "/.does-not-exist.")) | |
214 | (equal? (file-system-fold enter? leaf down up skip error '() name) | |
215 | `((error ,name ,ENOENT))))) | |
216 | ||
9977b316 LC |
217 | (let ((name (string-append %top-builddir "/test-EACCES"))) |
218 | (pass-if-equal "EACCES" | |
219 | `((error ,name ,EACCES)) | |
220 | (if (zero? (getuid)) | |
221 | ;; When run as root, this test would fail because root can | |
222 | ;; list the contents of #o000 directories. | |
223 | (throw 'unresolved) | |
224 | (with-file-tree %top-builddir '(directory "test-EACCES" #o000 | |
225 | (("a") ("b"))) | |
226 | (let ((enter? (lambda (n s r) #t)) | |
227 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
228 | (down (lambda (n s r) (cons `(down ,n) r))) | |
229 | (up (lambda (n s r) (cons `(up ,n) r))) | |
230 | (skip (lambda (n s r) (cons `(skip ,n) r))) | |
231 | (error (lambda (n s e r) (cons `(error ,n ,e) r)))) | |
232 | (file-system-fold enter? leaf down up skip error '() name)))))) | |
be96155b LC |
233 | |
234 | (pass-if "dangling symlink and lstat" | |
235 | (with-file-tree %top-builddir '(directory "test-dangling" | |
236 | (("dangling" -> "xxx"))) | |
237 | (let ((enter? (lambda (n s r) #t)) | |
238 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
239 | (down (lambda (n s r) (cons `(down ,n) r))) | |
240 | (up (lambda (n s r) (cons `(up ,n) r))) | |
241 | (skip (lambda (n s r) (cons `(skip ,n) r))) | |
242 | (error (lambda (n s e r) (cons `(error ,n ,e) r))) | |
243 | (name (string-append %top-builddir "/test-dangling"))) | |
244 | (equal? (file-system-fold enter? leaf down up skip error '() | |
245 | name) | |
246 | `((up ,name) | |
247 | (leaf ,(string-append name "/dangling")) | |
248 | (down ,name)))))) | |
249 | ||
250 | (pass-if "dangling symlink and stat" | |
251 | ;; Same as above, but using `stat' instead of `lstat'. | |
252 | (with-file-tree %top-builddir '(directory "test-dangling" | |
253 | (("dangling" -> "xxx"))) | |
254 | (let ((enter? (lambda (n s r) #t)) | |
255 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
256 | (down (lambda (n s r) (cons `(down ,n) r))) | |
257 | (up (lambda (n s r) (cons `(up ,n) r))) | |
258 | (skip (lambda (n s r) (cons `(skip ,n) r))) | |
259 | (error (lambda (n s e r) (cons `(error ,n ,e) r))) | |
260 | (name (string-append %top-builddir "/test-dangling"))) | |
261 | (equal? (file-system-fold enter? leaf down up skip error '() | |
262 | name stat) | |
263 | `((up ,name) | |
264 | (error ,(string-append name "/dangling") ,ENOENT) | |
265 | (down ,name))))))) | |
243db01e LC |
266 | |
267 | (with-test-prefix "file-system-tree" | |
268 | ||
269 | (pass-if "test-suite (never enter)" | |
270 | (match (file-system-tree %test-dir (lambda (n s) #f)) | |
271 | (("test-suite" (= stat:type 'directory)) ; no children | |
272 | #t))) | |
273 | ||
274 | (pass-if "test-suite/*" | |
275 | (match (file-system-tree %test-dir (lambda (n s) | |
276 | (string=? n %test-dir))) | |
277 | (("test-suite" (= stat:type 'directory) children ...) | |
278 | (any (match-lambda | |
279 | (("tests" (= stat:type 'directory)) ; no children | |
280 | #t) | |
281 | (_ #f)) | |
282 | children)))) | |
283 | ||
284 | (pass-if "test-suite (recursive)" | |
285 | (match (file-system-tree %test-dir) | |
286 | (("test-suite" (= stat:type 'directory) children ...) | |
287 | (any (match-lambda | |
288 | (("tests" (= stat:type 'directory) (= car files) ...) | |
289 | (let ((expected '("alist.test" "bytevectors.test" | |
290 | "ftw.test" "gc.test" "vlist.test"))) | |
291 | (lset= string=? | |
292 | (lset-intersection string=? files expected) | |
293 | expected))) | |
294 | (_ #f)) | |
be96155b LC |
295 | children)))) |
296 | ||
297 | (pass-if "ENOENT" | |
298 | (not (file-system-tree "/.does-not-exist.")))) | |
1629429d LC |
299 | |
300 | (with-test-prefix "scandir" | |
301 | ||
a2c66014 LC |
302 | (pass-if "top-srcdir" |
303 | (let ((valid? (negate (cut string-any #\/ <>)))) | |
304 | (match (scandir %top-srcdir) | |
305 | (((? valid? files) ...) | |
306 | ;; Both subdirs and files must be included. | |
307 | (let ((expected '("libguile" "README" "COPYING" | |
308 | "test-suite" "Makefile.am" | |
309 | "." ".."))) | |
310 | (lset= string=? | |
311 | (lset-intersection string=? files expected) | |
312 | expected)))))) | |
313 | ||
1629429d LC |
314 | (pass-if "test-suite" |
315 | (let ((select? (cut string-suffix? ".test" <>))) | |
316 | (match (scandir (string-append %test-dir "/tests") select?) | |
378daa5f | 317 | (("00-initial-env.test" (? select?) ...) |
de929870 LC |
318 | #t)))) |
319 | ||
320 | (pass-if "flat file" | |
be96155b LC |
321 | (not (scandir (string-append %test-dir "/Makefile.am")))) |
322 | ||
323 | (pass-if "EACCES" | |
378daa5f AW |
324 | (not (scandir "/.does-not-exist."))) |
325 | ||
326 | (pass-if "no select" | |
139ce194 LC |
327 | (null? (scandir %test-dir (lambda (_) #f)))) |
328 | ||
329 | ;; In Guile up to 2.0.6, this would return ("." ".." "link-to-dir"). | |
330 | (pass-if-equal "symlink to directory" | |
331 | '("." ".." "link-to-dir" "subdir") | |
332 | (with-file-tree %top-builddir '(directory "test-scandir-symlink" | |
333 | (("link-to-dir" -> "subdir") | |
334 | (directory "subdir" | |
335 | (("a"))))) | |
336 | (let ((name (string-append %top-builddir "/test-scandir-symlink"))) | |
337 | (scandir name))))) | |
be96155b LC |
338 | |
339 | ;;; Local Variables: | |
340 | ;;; eval: (put 'with-file-tree 'scheme-indent-function 2) | |
341 | ;;; End: |