Commit | Line | Data |
---|---|---|
c4e84357 | 1 | ;;;; ftw.scm --- file system tree walk |
df625172 | 2 | |
be96155b | 3 | ;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 Free Software Foundation, Inc. |
df625172 | 4 | ;;;; |
73be1d9e MV |
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. |
73be1d9e MV |
9 | ;;;; |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
df625172 | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
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 | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
df625172 TTN |
18 | |
19 | ;;; Author: Thien-Thi Nguyen <ttn@gnu.org> | |
20 | ||
21 | ;;; Commentary: | |
22 | ||
23 | ;; Two procedures are provided: `ftw' and `nftw'. | |
24 | ||
25 | ;; NOTE: The following description was adapted from the GNU libc info page, w/ | |
26 | ;; significant modifications for a more "Schemey" interface. Most noticible | |
27 | ;; are the inlining of `struct FTW *' parameters `base' and `level' and the | |
28 | ;; omission of `descriptors' parameters. | |
29 | ||
30 | ;; * Types | |
31 | ;; | |
32 | ;; The X/Open specification defines two procedures to process whole | |
33 | ;; hierarchies of directories and the contained files. Both procedures | |
34 | ;; of this `ftw' family take as one of the arguments a callback procedure | |
35 | ;; which must be of these types. | |
36 | ;; | |
37 | ;; - Data Type: __ftw_proc_t | |
38 | ;; (lambda (filename statinfo flag) ...) => status | |
39 | ;; | |
40 | ;; Type for callback procedures given to the `ftw' procedure. The | |
41 | ;; first parameter is a filename, the second parameter is the | |
42 | ;; vector value as returned by calling `stat' on FILENAME. | |
43 | ;; | |
44 | ;; The last parameter is a symbol giving more information about | |
45 | ;; FILENAM. It can have one of the following values: | |
46 | ;; | |
47 | ;; `regular' | |
48 | ;; The current item is a normal file or files which do not fit | |
49 | ;; into one of the following categories. This means | |
50 | ;; especially special files, sockets etc. | |
51 | ;; | |
52 | ;; `directory' | |
53 | ;; The current item is a directory. | |
54 | ;; | |
55 | ;; `invalid-stat' | |
56 | ;; The `stat' call to fill the object pointed to by the second | |
57 | ;; parameter failed and so the information is invalid. | |
58 | ;; | |
59 | ;; `directory-not-readable' | |
60 | ;; The item is a directory which cannot be read. | |
61 | ;; | |
62 | ;; `symlink' | |
63 | ;; The item is a symbolic link. Since symbolic links are | |
64 | ;; normally followed seeing this value in a `ftw' callback | |
65 | ;; procedure means the referenced file does not exist. The | |
66 | ;; situation for `nftw' is different. | |
67 | ;; | |
68 | ;; - Data Type: __nftw_proc_t | |
69 | ;; (lambda (filename statinfo flag base level) ...) => status | |
70 | ;; | |
71 | ;; The first three arguments have the same as for the | |
72 | ;; `__ftw_proc_t' type. A difference is that for the third | |
73 | ;; argument some additional values are defined to allow finer | |
74 | ;; differentiation: | |
75 | ;; | |
76 | ;; `directory-processed' | |
77 | ;; The current item is a directory and all subdirectories have | |
78 | ;; already been visited and reported. This flag is returned | |
79 | ;; instead of `directory' if the `depth' flag is given to | |
80 | ;; `nftw' (see below). | |
81 | ;; | |
82 | ;; `stale-symlink' | |
83 | ;; The current item is a stale symbolic link. The file it | |
84 | ;; points to does not exist. | |
85 | ;; | |
86 | ;; The last two parameters are described below. They contain | |
87 | ;; information to help interpret FILENAME and give some information | |
88 | ;; about current state of the traversal of the directory hierarchy. | |
89 | ;; | |
90 | ;; `base' | |
91 | ;; The value specifies which part of the filename argument | |
92 | ;; given in the first parameter to the callback procedure is | |
93 | ;; the name of the file. The rest of the string is the path | |
94 | ;; to locate the file. This information is especially | |
95 | ;; important if the `chdir' flag for `nftw' was set since then | |
96 | ;; the current directory is the one the current item is found | |
97 | ;; in. | |
98 | ;; | |
99 | ;; `level' | |
100 | ;; While processing the directory the procedures tracks how | |
101 | ;; many directories have been examined to find the current | |
102 | ;; item. This nesting level is 0 for the item given starting | |
103 | ;; item (file or directory) and is incremented by one for each | |
104 | ;; entered directory. | |
105 | ;; | |
106 | ;; * Procedure: (ftw filename proc . options) | |
c4e84357 | 107 | ;; Do a file system tree walk starting at FILENAME using PROC. |
df625172 TTN |
108 | ;; |
109 | ;; The `ftw' procedure calls the callback procedure given in the | |
110 | ;; parameter PROC for every item which is found in the directory | |
111 | ;; specified by FILENAME and all directories below. The procedure | |
112 | ;; follows symbolic links if necessary but does not process an item | |
113 | ;; twice. If FILENAME names no directory this item is the only | |
114 | ;; object reported by calling the callback procedure. | |
115 | ;; | |
116 | ;; The filename given to the callback procedure is constructed by | |
117 | ;; taking the FILENAME parameter and appending the names of all | |
118 | ;; passed directories and then the local file name. So the | |
119 | ;; callback procedure can use this parameter to access the file. | |
120 | ;; Before the callback procedure is called `ftw' calls `stat' for | |
121 | ;; this file and passes the information up to the callback | |
122 | ;; procedure. If this `stat' call was not successful the failure is | |
123 | ;; indicated by setting the flag argument of the callback procedure | |
124 | ;; to `invalid-stat'. Otherwise the flag is set according to the | |
125 | ;; description given in the description of `__ftw_proc_t' above. | |
126 | ;; | |
127 | ;; The callback procedure is expected to return non-#f to indicate | |
128 | ;; that no error occurred and the processing should be continued. | |
129 | ;; If an error occurred in the callback procedure or the call to | |
130 | ;; `ftw' shall return immediately the callback procedure can return | |
131 | ;; #f. This is the only correct way to stop the procedure. The | |
132 | ;; program must not use `throw' or similar techniques to continue | |
133 | ;; the program in another place. [Can we relax this? --ttn] | |
134 | ;; | |
135 | ;; The return value of the `ftw' procedure is #t if all callback | |
136 | ;; procedure calls returned #t and all actions performed by the | |
137 | ;; `ftw' succeeded. If some procedure call failed (other than | |
138 | ;; calling `stat' on an item) the procedure returns #f. If a | |
139 | ;; callback procedure returns a value other than #t this value is | |
140 | ;; returned as the return value of `ftw'. | |
141 | ;; | |
142 | ;; * Procedure: (nftw filename proc . control-flags) | |
c4e84357 | 143 | ;; Do a new-style file system tree walk starting at FILENAME using PROC. |
df625172 TTN |
144 | ;; Various optional CONTROL-FLAGS alter the default behavior. |
145 | ;; | |
146 | ;; The `nftw' procedures works like the `ftw' procedures. It calls | |
147 | ;; the callback procedure PROC for all items it finds in the | |
148 | ;; directory FILENAME and below. | |
149 | ;; | |
150 | ;; The differences are that for one the callback procedure is of a | |
151 | ;; different type. It takes also `base' and `level' parameters as | |
152 | ;; described above. | |
153 | ;; | |
154 | ;; The second difference is that `nftw' takes additional optional | |
155 | ;; arguments which are zero or more of the following symbols: | |
156 | ;; | |
157 | ;; physical' | |
158 | ;; While traversing the directory symbolic links are not | |
159 | ;; followed. I.e., if this flag is given symbolic links are | |
160 | ;; reported using the `symlink' value for the type parameter | |
161 | ;; to the callback procedure. Please note that if this flag is | |
162 | ;; used the appearance of `symlink' in a callback procedure | |
163 | ;; does not mean the referenced file does not exist. To | |
164 | ;; indicate this the extra value `stale-symlink' exists. | |
165 | ;; | |
166 | ;; mount' | |
167 | ;; The callback procedure is only called for items which are on | |
c4e84357 | 168 | ;; the same mounted file system as the directory given as the |
df625172 TTN |
169 | ;; FILENAME parameter to `nftw'. |
170 | ;; | |
171 | ;; chdir' | |
172 | ;; If this flag is given the current working directory is | |
173 | ;; changed to the directory containing the reported object | |
174 | ;; before the callback procedure is called. | |
175 | ;; | |
176 | ;; depth' | |
177 | ;; If this option is given the procedure visits first all files | |
178 | ;; and subdirectories before the callback procedure is called | |
179 | ;; for the directory itself (depth-first processing). This | |
180 | ;; also means the type flag given to the callback procedure is | |
181 | ;; `directory-processed' and not `directory'. | |
182 | ;; | |
183 | ;; The return value is computed in the same way as for `ftw'. | |
184 | ;; `nftw' returns #t if no failure occurred in `nftw' and all | |
185 | ;; callback procedure call return values are also #t. For internal | |
186 | ;; errors such as memory problems the error `ftw-error' is thrown. | |
187 | ;; If the return value of a callback invocation is not #t this | |
188 | ;; very same value is returned. | |
189 | ||
190 | ;;; Code: | |
191 | ||
192 | (define-module (ice-9 ftw) | |
243db01e LC |
193 | #:use-module (ice-9 match) |
194 | #:use-module (ice-9 vlist) | |
195 | #:use-module (srfi srfi-1) | |
1629429d | 196 | #:autoload (ice-9 i18n) (string-locale<?) |
243db01e LC |
197 | #:export (ftw nftw |
198 | file-system-fold | |
1629429d LC |
199 | file-system-tree |
200 | scandir)) | |
df625172 TTN |
201 | |
202 | (define (directory-files dir) | |
203 | (let ((dir-stream (opendir dir))) | |
204 | (let loop ((new (readdir dir-stream)) | |
205 | (acc '())) | |
206 | (if (eof-object? new) | |
eb041507 MV |
207 | (begin |
208 | (closedir dir-stream) | |
209 | acc) | |
df625172 TTN |
210 | (loop (readdir dir-stream) |
211 | (if (or (string=? "." new) ;;; ignore | |
212 | (string=? ".." new)) ;;; ignore | |
213 | acc | |
214 | (cons new acc))))))) | |
215 | ||
216 | (define (pathify . nodes) | |
217 | (let loop ((nodes nodes) | |
218 | (result "")) | |
219 | (if (null? nodes) | |
220 | (or (and (string=? "" result) "") | |
221 | (substring result 1 (string-length result))) | |
222 | (loop (cdr nodes) (string-append result "/" (car nodes)))))) | |
223 | ||
224 | (define (abs? filename) | |
225 | (char=? #\/ (string-ref filename 0))) | |
226 | ||
afc4ccd4 KR |
227 | ;; `visited?-proc' returns a test procedure VISITED? which when called as |
228 | ;; (VISITED? stat-obj) returns #f the first time a distinct file is seen, | |
229 | ;; then #t on any subsequent sighting of it. | |
230 | ;; | |
231 | ;; stat:dev and stat:ino together uniquely identify a file (see "Attribute | |
232 | ;; Meanings" in the glibc manual). Often there'll be just one dev, and | |
233 | ;; usually there's just a handful mounted, so the strategy here is a small | |
234 | ;; hash table indexed by dev, containing hash tables indexed by ino. | |
235 | ;; | |
236 | ;; It'd be possible to make a pair (dev . ino) and use that as the key to a | |
237 | ;; single hash table. It'd use an extra pair for every file visited, but | |
238 | ;; might be a little faster if it meant less scheme code. | |
239 | ;; | |
df625172 | 240 | (define (visited?-proc size) |
afc4ccd4 | 241 | (let ((dev-hash (make-hash-table 7))) |
df625172 | 242 | (lambda (s) |
afc4ccd4 KR |
243 | (and s |
244 | (let ((ino-hash (hashv-ref dev-hash (stat:dev s))) | |
245 | (ino (stat:ino s))) | |
246 | (or ino-hash | |
247 | (begin | |
248 | (set! ino-hash (make-hash-table size)) | |
249 | (hashv-set! dev-hash (stat:dev s) ino-hash))) | |
250 | (or (hashv-ref ino-hash ino) | |
251 | (begin | |
252 | (hashv-set! ino-hash ino #t) | |
253 | #f))))))) | |
df625172 TTN |
254 | |
255 | (define (stat-dir-readable?-proc uid gid) | |
256 | (let ((uid (getuid)) | |
257 | (gid (getgid))) | |
258 | (lambda (s) | |
259 | (let* ((perms (stat:perms s)) | |
260 | (perms-bit-set? (lambda (mask) | |
261 | (not (= 0 (logand mask perms)))))) | |
262 | (or (and (= uid (stat:uid s)) | |
263 | (perms-bit-set? #o400)) | |
264 | (and (= gid (stat:gid s)) | |
265 | (perms-bit-set? #o040)) | |
266 | (perms-bit-set? #o004)))))) | |
267 | ||
268 | (define (stat&flag-proc dir-readable? . control-flags) | |
269 | (let* ((directory-flag (if (memq 'depth control-flags) | |
270 | 'directory-processed | |
271 | 'directory)) | |
272 | (stale-symlink-flag (if (memq 'nftw-style control-flags) | |
273 | 'stale-symlink | |
274 | 'symlink)) | |
275 | (physical? (memq 'physical control-flags)) | |
276 | (easy-flag (lambda (s) | |
277 | (let ((type (stat:type s))) | |
278 | (if (eq? 'directory type) | |
279 | (if (dir-readable? s) | |
280 | directory-flag | |
281 | 'directory-not-readable) | |
282 | 'regular))))) | |
283 | (lambda (name) | |
284 | (let ((s (false-if-exception (lstat name)))) | |
285 | (cond ((not s) | |
286 | (values s 'invalid-stat)) | |
287 | ((eq? 'symlink (stat:type s)) | |
288 | (let ((s-follow (false-if-exception (stat name)))) | |
289 | (cond ((not s-follow) | |
290 | (values s stale-symlink-flag)) | |
291 | ((and s-follow physical?) | |
292 | (values s 'symlink)) | |
293 | ((and s-follow (not physical?)) | |
294 | (values s-follow (easy-flag s-follow)))))) | |
295 | (else (values s (easy-flag s)))))))) | |
296 | ||
297 | (define (clean name) | |
298 | (let ((last-char-index (1- (string-length name)))) | |
299 | (if (char=? #\/ (string-ref name last-char-index)) | |
300 | (substring name 0 last-char-index) | |
301 | name))) | |
302 | ||
303 | (define (ftw filename proc . options) | |
304 | (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr) | |
305 | (else 211)))) | |
306 | (stat&flag (stat&flag-proc | |
307 | (stat-dir-readable?-proc (getuid) (getgid))))) | |
308 | (letrec ((go (lambda (fullname) | |
309 | (call-with-values (lambda () (stat&flag fullname)) | |
310 | (lambda (s flag) | |
311 | (or (visited? s) | |
312 | (let ((ret (proc fullname s flag))) ; callback | |
313 | (or (eq? #t ret) | |
314 | (throw 'ftw-early-exit ret)) | |
315 | (and (eq? 'directory flag) | |
316 | (for-each | |
317 | (lambda (child) | |
318 | (go (pathify fullname child))) | |
319 | (directory-files fullname))) | |
320 | #t))))))) | |
321 | (catch 'ftw-early-exit | |
322 | (lambda () (go (clean filename))) | |
323 | (lambda (key val) val))))) | |
324 | ||
325 | (define (nftw filename proc . control-flags) | |
326 | (let* ((od (getcwd)) ; orig dir | |
327 | (odev (let ((s (false-if-exception (lstat filename)))) | |
328 | (if s (stat:dev s) -1))) | |
329 | (same-dev? (if (memq 'mount control-flags) | |
330 | (lambda (s) (= (stat:dev s) odev)) | |
331 | (lambda (s) #t))) | |
332 | (base-sub (lambda (name base) (substring name 0 base))) | |
333 | (maybe-cd (if (memq 'chdir control-flags) | |
334 | (if (abs? filename) | |
335 | (lambda (fullname base) | |
336 | (or (= 0 base) | |
337 | (chdir (base-sub fullname base)))) | |
338 | (lambda (fullname base) | |
339 | (chdir | |
340 | (pathify od (base-sub fullname base))))) | |
341 | (lambda (fullname base) #t))) | |
342 | (maybe-cd-back (if (memq 'chdir control-flags) | |
343 | (lambda () (chdir od)) | |
344 | (lambda () #t))) | |
345 | (depth-first? (memq 'depth control-flags)) | |
346 | (visited? (visited?-proc | |
347 | (cond ((memq 'hash-size control-flags) => cadr) | |
348 | (else 211)))) | |
349 | (has-kids? (if depth-first? | |
350 | (lambda (flag) (eq? flag 'directory-processed)) | |
351 | (lambda (flag) (eq? flag 'directory)))) | |
352 | (stat&flag (apply stat&flag-proc | |
353 | (stat-dir-readable?-proc (getuid) (getgid)) | |
354 | (cons 'nftw-style control-flags)))) | |
355 | (letrec ((go (lambda (fullname base level) | |
356 | (call-with-values (lambda () (stat&flag fullname)) | |
357 | (lambda (s flag) | |
358 | (letrec ((self (lambda () | |
359 | (maybe-cd fullname base) | |
360 | ;; the callback | |
361 | (let ((ret (proc fullname s flag | |
362 | base level))) | |
363 | (maybe-cd-back) | |
364 | (or (eq? #t ret) | |
365 | (throw 'nftw-early-exit ret))))) | |
366 | (kids (lambda () | |
367 | (and (has-kids? flag) | |
368 | (for-each | |
369 | (lambda (child) | |
370 | (go (pathify fullname child) | |
371 | (1+ (string-length | |
372 | fullname)) | |
373 | (1+ level))) | |
374 | (directory-files fullname)))))) | |
375 | (or (visited? s) | |
376 | (not (same-dev? s)) | |
377 | (if depth-first? | |
378 | (begin (kids) (self)) | |
379 | (begin (self) (kids))))))) | |
380 | #t))) | |
381 | (let ((ret (catch 'nftw-early-exit | |
382 | (lambda () (go (clean filename) 0 0)) | |
383 | (lambda (key val) val)))) | |
384 | (chdir od) | |
385 | ret)))) | |
386 | ||
243db01e LC |
387 | \f |
388 | ;;; | |
389 | ;;; `file-system-fold' & co. | |
390 | ;;; | |
391 | ||
be96155b LC |
392 | (define-syntax-rule (errno-if-exception expr) |
393 | (catch 'system-error | |
394 | (lambda () | |
395 | expr) | |
396 | (lambda args | |
397 | (system-error-errno args)))) | |
398 | ||
399 | (define* (file-system-fold enter? leaf down up skip error init file-name | |
af98fafa | 400 | #:optional (stat lstat)) |
243db01e LC |
401 | "Traverse the directory at FILE-NAME, recursively. Enter |
402 | sub-directories only when (ENTER? PATH STAT RESULT) returns true. When | |
403 | a sub-directory is entered, call (DOWN PATH STAT RESULT), where PATH is | |
af98fafa | 404 | the path of the sub-directory and STAT the result of (stat PATH); when |
243db01e LC |
405 | it is left, call (UP PATH STAT RESULT). For each file in a directory, |
406 | call (LEAF PATH STAT RESULT). When ENTER? returns false, call (SKIP | |
be96155b LC |
407 | PATH STAT RESULT). When an `opendir' or STAT call raises an exception, |
408 | call (ERROR PATH STAT ERRNO RESULT), with ERRNO being the operating | |
409 | system error number that was raised. | |
410 | ||
411 | Return the result of these successive applications. | |
af98fafa LC |
412 | When FILE-NAME names a flat file, (LEAF PATH STAT INIT) is returned. |
413 | The optional STAT parameter defaults to `lstat'." | |
243db01e LC |
414 | |
415 | (define (mark v s) | |
416 | (vhash-cons (cons (stat:dev s) (stat:ino s)) #t v)) | |
417 | ||
418 | (define (visited? v s) | |
419 | (vhash-assoc (cons (stat:dev s) (stat:ino s)) v)) | |
420 | ||
421 | (let loop ((name file-name) | |
422 | (path "") | |
be96155b | 423 | (dir-stat (errno-if-exception (stat file-name))) |
243db01e LC |
424 | (result init) |
425 | (visited vlist-null)) | |
426 | ||
427 | (define full-name | |
428 | (if (string=? path "") | |
429 | name | |
430 | (string-append path "/" name))) | |
431 | ||
432 | (cond | |
be96155b | 433 | ((integer? dir-stat) |
243db01e | 434 | ;; FILE-NAME is not readable. |
be96155b | 435 | (error full-name #f dir-stat result)) |
243db01e LC |
436 | ((visited? visited dir-stat) |
437 | (values result visited)) | |
438 | ((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time | |
439 | (if (enter? full-name dir-stat result) | |
be96155b | 440 | (let ((dir (errno-if-exception (opendir full-name))) |
243db01e | 441 | (visited (mark visited dir-stat))) |
be96155b LC |
442 | (cond |
443 | ((directory-stream? dir) | |
444 | (let liip ((entry (readdir dir)) | |
445 | (result (down full-name dir-stat result)) | |
446 | (subdirs '())) | |
447 | (cond ((eof-object? entry) | |
448 | (begin | |
449 | (closedir dir) | |
450 | (let ((r+v | |
451 | (fold (lambda (subdir result+visited) | |
452 | (call-with-values | |
453 | (lambda () | |
454 | (loop (car subdir) | |
455 | full-name | |
456 | (cdr subdir) | |
457 | (car result+visited) | |
458 | (cdr result+visited))) | |
459 | cons)) | |
460 | (cons result visited) | |
461 | subdirs))) | |
462 | (values (up full-name dir-stat (car r+v)) | |
463 | (cdr r+v))))) | |
464 | ((or (string=? entry ".") | |
465 | (string=? entry "..")) | |
466 | (liip (readdir dir) | |
467 | result | |
468 | subdirs)) | |
469 | (else | |
470 | (let* ((child (string-append full-name "/" entry)) | |
471 | (st (errno-if-exception (stat child)))) | |
472 | (if (integer? st) ; CHILD is a dangling symlink? | |
473 | (liip (readdir dir) | |
474 | (error child #f st result) | |
475 | subdirs) | |
476 | (if (eq? (stat:type st) 'directory) | |
477 | (liip (readdir dir) | |
478 | result | |
479 | (alist-cons entry st subdirs)) | |
480 | (liip (readdir dir) | |
481 | (leaf child st result) | |
482 | subdirs)))))))) | |
483 | (else | |
484 | ;; Directory FULL-NAME not readable, but it is stat'able. | |
485 | (values (error full-name dir-stat dir result) | |
486 | visited)))) | |
243db01e LC |
487 | (values (skip full-name dir-stat result) |
488 | (mark visited dir-stat)))) | |
489 | (else | |
490 | ;; Caller passed a FILE-NAME that names a flat file, not a directory. | |
491 | (leaf full-name dir-stat result))))) | |
492 | ||
af98fafa LC |
493 | (define* (file-system-tree file-name |
494 | #:optional (enter? (lambda (n s) #t)) | |
495 | (stat lstat)) | |
243db01e | 496 | "Return a tree of the form (FILE-NAME STAT CHILDREN ...) where STAT is |
be96155b | 497 | the result of (STAT FILE-NAME) and CHILDREN are similar structures for |
243db01e LC |
498 | each file contained in FILE-NAME when it designates a directory. The |
499 | optional ENTER? predicate is invoked as (ENTER? NAME STAT) and should | |
500 | return true to allow recursion into directory NAME; the default value is | |
501 | a procedure that always returns #t. When a directory does not match | |
502 | ENTER?, it nonetheless appears in the resulting tree, only with zero | |
be96155b LC |
503 | children. The optional STAT parameter defaults to `lstat'. Return #f |
504 | when FILE-NAME is not readable." | |
243db01e LC |
505 | (define (enter?* name stat result) |
506 | (enter? name stat)) | |
507 | (define (leaf name stat result) | |
508 | (match result | |
509 | (((siblings ...) rest ...) | |
510 | (cons (alist-cons (basename name) (cons stat '()) siblings) | |
511 | rest)))) | |
512 | (define (down name stat result) | |
513 | (cons '() result)) | |
514 | (define (up name stat result) | |
515 | (match result | |
516 | (((children ...) (siblings ...) rest ...) | |
517 | (cons (alist-cons (basename name) (cons stat children) | |
518 | siblings) | |
519 | rest)))) | |
520 | (define skip ; keep an entry for skipped directories | |
521 | leaf) | |
be96155b LC |
522 | (define (error name stat errno result) |
523 | (if (string=? name file-name) | |
524 | result | |
525 | (leaf name stat result))) | |
243db01e | 526 | |
be96155b LC |
527 | (match (file-system-fold enter?* leaf down up skip error '(()) |
528 | file-name stat) | |
529 | (((tree)) tree) | |
530 | ((()) #f))) ; FILE-NAME is unreadable | |
243db01e | 531 | |
1629429d LC |
532 | (define* (scandir name #:optional (select? (const #t)) |
533 | (entry<? string-locale<?)) | |
534 | "Return the list of the names of files contained in directory NAME | |
535 | that match predicate SELECT? (by default, all files.) The returned list | |
536 | of file names is sorted according to ENTRY<?, which defaults to | |
de929870 | 537 | `string-locale<?'. Return #f when NAME is unreadable or is not a directory." |
fa8110f2 LC |
538 | (define (enter? dir stat result) |
539 | (and stat (string=? dir name))) | |
1629429d LC |
540 | |
541 | (define (leaf name stat result) | |
542 | (if (select? name) | |
de929870 LC |
543 | (and (pair? result) ; must have a "." entry |
544 | (cons (basename name) result)) | |
1629429d LC |
545 | result)) |
546 | ||
547 | (define (down name stat result) | |
de929870 | 548 | (list ".")) |
1629429d LC |
549 | |
550 | (define (up name stat result) | |
551 | (cons ".." result)) | |
552 | ||
553 | (define (skip name stat result) | |
fa8110f2 | 554 | ;; All the sub-directories are skipped. |
a2c66014 | 555 | (cons (basename name) result)) |
1629429d | 556 | |
be96155b LC |
557 | (define (error name* stat errno result) |
558 | (if (string=? name name*) ; top-level NAME is unreadable | |
559 | result | |
560 | (cons (basename name*) result))) | |
561 | ||
562 | (and=> (file-system-fold enter? leaf down up skip error #f name stat) | |
1629429d LC |
563 | (lambda (files) |
564 | (sort files entry<?)))) | |
565 | ||
df625172 | 566 | ;;; ftw.scm ends here |