1 ;;;; ftw.scm --- filesystem tree walk
3 ;;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
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
8 ;;;; version 2.1 of the License, or (at your option) any later version.
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.
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
19 ;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
23 ;; Two procedures are provided: `ftw' and `nftw'.
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.
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.
37 ;; - Data Type: __ftw_proc_t
38 ;; (lambda (filename statinfo flag) ...) => status
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.
44 ;; The last parameter is a symbol giving more information about
45 ;; FILENAM. It can have one of the following values:
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.
53 ;; The current item is a directory.
56 ;; The `stat' call to fill the object pointed to by the second
57 ;; parameter failed and so the information is invalid.
59 ;; `directory-not-readable'
60 ;; The item is a directory which cannot be read.
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.
68 ;; - Data Type: __nftw_proc_t
69 ;; (lambda (filename statinfo flag base level) ...) => status
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
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).
83 ;; The current item is a stale symbolic link. The file it
84 ;; points to does not exist.
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.
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
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.
106 ;; * Procedure: (ftw filename proc . options)
107 ;; Do a filesystem tree walk starting at FILENAME using PROC.
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.
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.
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]
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'.
142 ;; * Procedure: (nftw filename proc . control-flags)
143 ;; Do a new-style filesystem tree walk starting at FILENAME using PROC.
144 ;; Various optional CONTROL-FLAGS alter the default behavior.
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.
150 ;; The differences are that for one the callback procedure is of a
151 ;; different type. It takes also `base' and `level' parameters as
154 ;; The second difference is that `nftw' takes additional optional
155 ;; arguments which are zero or more of the following symbols:
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.
167 ;; The callback procedure is only called for items which are on
168 ;; the same mounted filesystem as the directory given as the
169 ;; FILENAME parameter to `nftw'.
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.
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'.
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.
192 (define-module (ice-9 ftw)
195 (define (directory-files dir)
196 (let ((dir-stream (opendir dir)))
197 (let loop ((new (readdir dir-stream))
199 (if (eof-object? new)
201 (closedir dir-stream)
203 (loop (readdir dir-stream)
204 (if (or (string=? "." new) ;;; ignore
205 (string=? ".." new)) ;;; ignore
209 (define (pathify . nodes)
210 (let loop ((nodes nodes)
213 (or (and (string=? "" result) "")
214 (substring result 1 (string-length result)))
215 (loop (cdr nodes) (string-append result "/" (car nodes))))))
217 (define (abs? filename)
218 (char=? #\/ (string-ref filename 0)))
220 ;; `visited?-proc' returns a test procedure VISITED? which when called as
221 ;; (VISITED? stat-obj) returns #f the first time a distinct file is seen,
222 ;; then #t on any subsequent sighting of it.
224 ;; stat:dev and stat:ino together uniquely identify a file (see "Attribute
225 ;; Meanings" in the glibc manual). Often there'll be just one dev, and
226 ;; usually there's just a handful mounted, so the strategy here is a small
227 ;; hash table indexed by dev, containing hash tables indexed by ino.
229 ;; It'd be possible to make a pair (dev . ino) and use that as the key to a
230 ;; single hash table. It'd use an extra pair for every file visited, but
231 ;; might be a little faster if it meant less scheme code.
233 (define (visited?-proc size)
234 (let ((dev-hash (make-hash-table 7)))
237 (let ((ino-hash (hashv-ref dev-hash (stat:dev s)))
241 (set! ino-hash (make-hash-table size))
242 (hashv-set! dev-hash (stat:dev s) ino-hash)))
243 (or (hashv-ref ino-hash ino)
245 (hashv-set! ino-hash ino #t)
248 (define (stat-dir-readable?-proc uid gid)
252 (let* ((perms (stat:perms s))
253 (perms-bit-set? (lambda (mask)
254 (not (= 0 (logand mask perms))))))
255 (or (and (= uid (stat:uid s))
256 (perms-bit-set? #o400))
257 (and (= gid (stat:gid s))
258 (perms-bit-set? #o040))
259 (perms-bit-set? #o004))))))
261 (define (stat&flag-proc dir-readable? . control-flags)
262 (let* ((directory-flag (if (memq 'depth control-flags)
265 (stale-symlink-flag (if (memq 'nftw-style control-flags)
268 (physical? (memq 'physical control-flags))
269 (easy-flag (lambda (s)
270 (let ((type (stat:type s)))
271 (if (eq? 'directory type)
272 (if (dir-readable? s)
274 'directory-not-readable)
277 (let ((s (false-if-exception (lstat name))))
279 (values s 'invalid-stat))
280 ((eq? 'symlink (stat:type s))
281 (let ((s-follow (false-if-exception (stat name))))
282 (cond ((not s-follow)
283 (values s stale-symlink-flag))
284 ((and s-follow physical?)
286 ((and s-follow (not physical?))
287 (values s-follow (easy-flag s-follow))))))
288 (else (values s (easy-flag s))))))))
291 (let ((last-char-index (1- (string-length name))))
292 (if (char=? #\/ (string-ref name last-char-index))
293 (substring name 0 last-char-index)
296 (define (ftw filename proc . options)
297 (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr)
299 (stat&flag (stat&flag-proc
300 (stat-dir-readable?-proc (getuid) (getgid)))))
301 (letrec ((go (lambda (fullname)
302 (call-with-values (lambda () (stat&flag fullname))
305 (let ((ret (proc fullname s flag))) ; callback
307 (throw 'ftw-early-exit ret))
308 (and (eq? 'directory flag)
311 (go (pathify fullname child)))
312 (directory-files fullname)))
314 (catch 'ftw-early-exit
315 (lambda () (go (clean filename)))
316 (lambda (key val) val)))))
318 (define (nftw filename proc . control-flags)
319 (let* ((od (getcwd)) ; orig dir
320 (odev (let ((s (false-if-exception (lstat filename))))
321 (if s (stat:dev s) -1)))
322 (same-dev? (if (memq 'mount control-flags)
323 (lambda (s) (= (stat:dev s) odev))
325 (base-sub (lambda (name base) (substring name 0 base)))
326 (maybe-cd (if (memq 'chdir control-flags)
328 (lambda (fullname base)
330 (chdir (base-sub fullname base))))
331 (lambda (fullname base)
333 (pathify od (base-sub fullname base)))))
334 (lambda (fullname base) #t)))
335 (maybe-cd-back (if (memq 'chdir control-flags)
336 (lambda () (chdir od))
338 (depth-first? (memq 'depth control-flags))
339 (visited? (visited?-proc
340 (cond ((memq 'hash-size control-flags) => cadr)
342 (has-kids? (if depth-first?
343 (lambda (flag) (eq? flag 'directory-processed))
344 (lambda (flag) (eq? flag 'directory))))
345 (stat&flag (apply stat&flag-proc
346 (stat-dir-readable?-proc (getuid) (getgid))
347 (cons 'nftw-style control-flags))))
348 (letrec ((go (lambda (fullname base level)
349 (call-with-values (lambda () (stat&flag fullname))
351 (letrec ((self (lambda ()
352 (maybe-cd fullname base)
354 (let ((ret (proc fullname s flag
358 (throw 'nftw-early-exit ret)))))
360 (and (has-kids? flag)
363 (go (pathify fullname child)
367 (directory-files fullname))))))
371 (begin (kids) (self))
372 (begin (self) (kids)))))))
374 (let ((ret (catch 'nftw-early-exit
375 (lambda () (go (clean filename) 0 0))
376 (lambda (key val) val))))
380 ;;; ftw.scm ends here