Commit | Line | Data |
---|---|---|
8ab3d8a0 KR |
1 | ;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*- |
2 | ;;;; | |
243db01e | 3 | ;;;; Copyright 2006, 2011 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 | ||
84 | (define %top-srcdir | |
85 | (assq-ref %guile-build-info 'top_srcdir)) | |
86 | ||
87 | (define %test-dir | |
88 | (string-append %top-srcdir "/test-suite")) | |
89 | ||
90 | (with-test-prefix "file-system-fold" | |
91 | ||
92 | (pass-if "test-suite" | |
93 | (let ((enter? (lambda (n s r) | |
94 | ;; Enter only `test-suite/tests/'. | |
95 | (if (member `(down ,%test-dir) r) | |
96 | (string=? (basename n) "tests") | |
97 | (string=? (basename n) "test-suite")))) | |
98 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
99 | (down (lambda (n s r) (cons `(down ,n) r))) | |
100 | (up (lambda (n s r) (cons `(up ,n) r))) | |
101 | (skip (lambda (n s r) (cons `(skip ,n) r)))) | |
102 | (define seq | |
103 | (reverse | |
104 | (file-system-fold enter? leaf down up skip '() %test-dir))) | |
105 | ||
106 | (match seq | |
107 | ((('down (? (cut string=? <> %test-dir))) | |
108 | between ... | |
109 | ('up (? (cut string=? <> %test-dir)))) | |
110 | (and (any (match-lambda (('leaf (= basename "lib.scm")) #t) (_ #f)) | |
111 | between) | |
112 | (any (match-lambda (('down (= basename "tests")) #t) (_ #f)) | |
113 | between) | |
114 | (any (match-lambda (('leaf (= basename "alist.test")) #t) (_ #f)) | |
115 | between) | |
116 | (any (match-lambda (('up (= basename "tests")) #t) (_ #f)) | |
117 | between) | |
118 | (any (match-lambda (('skip (= basename "vm")) #t) (_ #f)) | |
119 | between)))))) | |
120 | ||
121 | (pass-if "test-suite (never enter)" | |
122 | (let ((enter? (lambda (n s r) #f)) | |
123 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
124 | (down (lambda (n s r) (cons `(down ,n) r))) | |
125 | (up (lambda (n s r) (cons `(up ,n) r))) | |
126 | (skip (lambda (n s r) (cons `(skip ,n) r)))) | |
127 | (equal? (file-system-fold enter? leaf down up skip '() %test-dir) | |
128 | `((skip , %test-dir))))) | |
129 | ||
130 | (pass-if "test-suite/lib.scm (flat file)" | |
131 | (let ((enter? (lambda (n s r) #t)) | |
132 | (leaf (lambda (n s r) (cons `(leaf ,n) r))) | |
133 | (down (lambda (n s r) (cons `(down ,n) r))) | |
134 | (up (lambda (n s r) (cons `(up ,n) r))) | |
135 | (skip (lambda (n s r) (cons `(skip ,n) r))) | |
136 | (name (string-append %test-dir "/lib.scm"))) | |
137 | (equal? (file-system-fold enter? leaf down up skip '() name) | |
138 | `((leaf ,name)))))) | |
139 | ||
140 | (with-test-prefix "file-system-tree" | |
141 | ||
142 | (pass-if "test-suite (never enter)" | |
143 | (match (file-system-tree %test-dir (lambda (n s) #f)) | |
144 | (("test-suite" (= stat:type 'directory)) ; no children | |
145 | #t))) | |
146 | ||
147 | (pass-if "test-suite/*" | |
148 | (match (file-system-tree %test-dir (lambda (n s) | |
149 | (string=? n %test-dir))) | |
150 | (("test-suite" (= stat:type 'directory) children ...) | |
151 | (any (match-lambda | |
152 | (("tests" (= stat:type 'directory)) ; no children | |
153 | #t) | |
154 | (_ #f)) | |
155 | children)))) | |
156 | ||
157 | (pass-if "test-suite (recursive)" | |
158 | (match (file-system-tree %test-dir) | |
159 | (("test-suite" (= stat:type 'directory) children ...) | |
160 | (any (match-lambda | |
161 | (("tests" (= stat:type 'directory) (= car files) ...) | |
162 | (let ((expected '("alist.test" "bytevectors.test" | |
163 | "ftw.test" "gc.test" "vlist.test"))) | |
164 | (lset= string=? | |
165 | (lset-intersection string=? files expected) | |
166 | expected))) | |
167 | (_ #f)) | |
168 | children))))) | |
1629429d LC |
169 | |
170 | (with-test-prefix "scandir" | |
171 | ||
a2c66014 LC |
172 | (pass-if "top-srcdir" |
173 | (let ((valid? (negate (cut string-any #\/ <>)))) | |
174 | (match (scandir %top-srcdir) | |
175 | (((? valid? files) ...) | |
176 | ;; Both subdirs and files must be included. | |
177 | (let ((expected '("libguile" "README" "COPYING" | |
178 | "test-suite" "Makefile.am" | |
179 | "." ".."))) | |
180 | (lset= string=? | |
181 | (lset-intersection string=? files expected) | |
182 | expected)))))) | |
183 | ||
1629429d LC |
184 | (pass-if "test-suite" |
185 | (let ((select? (cut string-suffix? ".test" <>))) | |
186 | (match (scandir (string-append %test-dir "/tests") select?) | |
187 | (("." ".." "00-initial-env.test" (? select?) ...) | |
de929870 LC |
188 | #t)))) |
189 | ||
190 | (pass-if "flat file" | |
191 | (not (scandir (string-append %test-dir "/Makefile.am"))))) |