Commit | Line | Data |
---|---|---|
c4e84357 | 1 | ;;;; ftw.scm --- file system tree walk |
df625172 | 2 | |
cd5fea8d | 3 | ;;;; Copyright (C) 2002, 2003, 2006 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) | |
193 | :export (ftw nftw)) | |
194 | ||
195 | (define (directory-files dir) | |
196 | (let ((dir-stream (opendir dir))) | |
197 | (let loop ((new (readdir dir-stream)) | |
198 | (acc '())) | |
199 | (if (eof-object? new) | |
eb041507 MV |
200 | (begin |
201 | (closedir dir-stream) | |
202 | acc) | |
df625172 TTN |
203 | (loop (readdir dir-stream) |
204 | (if (or (string=? "." new) ;;; ignore | |
205 | (string=? ".." new)) ;;; ignore | |
206 | acc | |
207 | (cons new acc))))))) | |
208 | ||
209 | (define (pathify . nodes) | |
210 | (let loop ((nodes nodes) | |
211 | (result "")) | |
212 | (if (null? nodes) | |
213 | (or (and (string=? "" result) "") | |
214 | (substring result 1 (string-length result))) | |
215 | (loop (cdr nodes) (string-append result "/" (car nodes)))))) | |
216 | ||
217 | (define (abs? filename) | |
218 | (char=? #\/ (string-ref filename 0))) | |
219 | ||
afc4ccd4 KR |
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. | |
223 | ;; | |
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. | |
228 | ;; | |
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. | |
232 | ;; | |
df625172 | 233 | (define (visited?-proc size) |
afc4ccd4 | 234 | (let ((dev-hash (make-hash-table 7))) |
df625172 | 235 | (lambda (s) |
afc4ccd4 KR |
236 | (and s |
237 | (let ((ino-hash (hashv-ref dev-hash (stat:dev s))) | |
238 | (ino (stat:ino s))) | |
239 | (or ino-hash | |
240 | (begin | |
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) | |
244 | (begin | |
245 | (hashv-set! ino-hash ino #t) | |
246 | #f))))))) | |
df625172 TTN |
247 | |
248 | (define (stat-dir-readable?-proc uid gid) | |
249 | (let ((uid (getuid)) | |
250 | (gid (getgid))) | |
251 | (lambda (s) | |
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)))))) | |
260 | ||
261 | (define (stat&flag-proc dir-readable? . control-flags) | |
262 | (let* ((directory-flag (if (memq 'depth control-flags) | |
263 | 'directory-processed | |
264 | 'directory)) | |
265 | (stale-symlink-flag (if (memq 'nftw-style control-flags) | |
266 | 'stale-symlink | |
267 | 'symlink)) | |
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) | |
273 | directory-flag | |
274 | 'directory-not-readable) | |
275 | 'regular))))) | |
276 | (lambda (name) | |
277 | (let ((s (false-if-exception (lstat name)))) | |
278 | (cond ((not s) | |
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?) | |
285 | (values s 'symlink)) | |
286 | ((and s-follow (not physical?)) | |
287 | (values s-follow (easy-flag s-follow)))))) | |
288 | (else (values s (easy-flag s)))))))) | |
289 | ||
290 | (define (clean name) | |
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) | |
294 | name))) | |
295 | ||
296 | (define (ftw filename proc . options) | |
297 | (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr) | |
298 | (else 211)))) | |
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)) | |
303 | (lambda (s flag) | |
304 | (or (visited? s) | |
305 | (let ((ret (proc fullname s flag))) ; callback | |
306 | (or (eq? #t ret) | |
307 | (throw 'ftw-early-exit ret)) | |
308 | (and (eq? 'directory flag) | |
309 | (for-each | |
310 | (lambda (child) | |
311 | (go (pathify fullname child))) | |
312 | (directory-files fullname))) | |
313 | #t))))))) | |
314 | (catch 'ftw-early-exit | |
315 | (lambda () (go (clean filename))) | |
316 | (lambda (key val) val))))) | |
317 | ||
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)) | |
324 | (lambda (s) #t))) | |
325 | (base-sub (lambda (name base) (substring name 0 base))) | |
326 | (maybe-cd (if (memq 'chdir control-flags) | |
327 | (if (abs? filename) | |
328 | (lambda (fullname base) | |
329 | (or (= 0 base) | |
330 | (chdir (base-sub fullname base)))) | |
331 | (lambda (fullname base) | |
332 | (chdir | |
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)) | |
337 | (lambda () #t))) | |
338 | (depth-first? (memq 'depth control-flags)) | |
339 | (visited? (visited?-proc | |
340 | (cond ((memq 'hash-size control-flags) => cadr) | |
341 | (else 211)))) | |
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)) | |
350 | (lambda (s flag) | |
351 | (letrec ((self (lambda () | |
352 | (maybe-cd fullname base) | |
353 | ;; the callback | |
354 | (let ((ret (proc fullname s flag | |
355 | base level))) | |
356 | (maybe-cd-back) | |
357 | (or (eq? #t ret) | |
358 | (throw 'nftw-early-exit ret))))) | |
359 | (kids (lambda () | |
360 | (and (has-kids? flag) | |
361 | (for-each | |
362 | (lambda (child) | |
363 | (go (pathify fullname child) | |
364 | (1+ (string-length | |
365 | fullname)) | |
366 | (1+ level))) | |
367 | (directory-files fullname)))))) | |
368 | (or (visited? s) | |
369 | (not (same-dev? s)) | |
370 | (if depth-first? | |
371 | (begin (kids) (self)) | |
372 | (begin (self) (kids))))))) | |
373 | #t))) | |
374 | (let ((ret (catch 'nftw-early-exit | |
375 | (lambda () (go (clean filename) 0 0)) | |
376 | (lambda (key val) val)))) | |
377 | (chdir od) | |
378 | ret)))) | |
379 | ||
380 | ;;; ftw.scm ends here |