mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
00d0489205
Moved ice-9/ and oop/ under module/, with the idea being that we have only scheme under module/. Adjusted configure.in and Makefile.am appropriately. Put oop/ at the end of the compilation order.
380 lines
17 KiB
Scheme
380 lines
17 KiB
Scheme
;;;; ftw.scm --- filesystem tree walk
|
|
|
|
;;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2.1 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
|
|
|
;;; Commentary:
|
|
|
|
;; Two procedures are provided: `ftw' and `nftw'.
|
|
|
|
;; NOTE: The following description was adapted from the GNU libc info page, w/
|
|
;; significant modifications for a more "Schemey" interface. Most noticible
|
|
;; are the inlining of `struct FTW *' parameters `base' and `level' and the
|
|
;; omission of `descriptors' parameters.
|
|
|
|
;; * Types
|
|
;;
|
|
;; The X/Open specification defines two procedures to process whole
|
|
;; hierarchies of directories and the contained files. Both procedures
|
|
;; of this `ftw' family take as one of the arguments a callback procedure
|
|
;; which must be of these types.
|
|
;;
|
|
;; - Data Type: __ftw_proc_t
|
|
;; (lambda (filename statinfo flag) ...) => status
|
|
;;
|
|
;; Type for callback procedures given to the `ftw' procedure. The
|
|
;; first parameter is a filename, the second parameter is the
|
|
;; vector value as returned by calling `stat' on FILENAME.
|
|
;;
|
|
;; The last parameter is a symbol giving more information about
|
|
;; FILENAM. It can have one of the following values:
|
|
;;
|
|
;; `regular'
|
|
;; The current item is a normal file or files which do not fit
|
|
;; into one of the following categories. This means
|
|
;; especially special files, sockets etc.
|
|
;;
|
|
;; `directory'
|
|
;; The current item is a directory.
|
|
;;
|
|
;; `invalid-stat'
|
|
;; The `stat' call to fill the object pointed to by the second
|
|
;; parameter failed and so the information is invalid.
|
|
;;
|
|
;; `directory-not-readable'
|
|
;; The item is a directory which cannot be read.
|
|
;;
|
|
;; `symlink'
|
|
;; The item is a symbolic link. Since symbolic links are
|
|
;; normally followed seeing this value in a `ftw' callback
|
|
;; procedure means the referenced file does not exist. The
|
|
;; situation for `nftw' is different.
|
|
;;
|
|
;; - Data Type: __nftw_proc_t
|
|
;; (lambda (filename statinfo flag base level) ...) => status
|
|
;;
|
|
;; The first three arguments have the same as for the
|
|
;; `__ftw_proc_t' type. A difference is that for the third
|
|
;; argument some additional values are defined to allow finer
|
|
;; differentiation:
|
|
;;
|
|
;; `directory-processed'
|
|
;; The current item is a directory and all subdirectories have
|
|
;; already been visited and reported. This flag is returned
|
|
;; instead of `directory' if the `depth' flag is given to
|
|
;; `nftw' (see below).
|
|
;;
|
|
;; `stale-symlink'
|
|
;; The current item is a stale symbolic link. The file it
|
|
;; points to does not exist.
|
|
;;
|
|
;; The last two parameters are described below. They contain
|
|
;; information to help interpret FILENAME and give some information
|
|
;; about current state of the traversal of the directory hierarchy.
|
|
;;
|
|
;; `base'
|
|
;; The value specifies which part of the filename argument
|
|
;; given in the first parameter to the callback procedure is
|
|
;; the name of the file. The rest of the string is the path
|
|
;; to locate the file. This information is especially
|
|
;; important if the `chdir' flag for `nftw' was set since then
|
|
;; the current directory is the one the current item is found
|
|
;; in.
|
|
;;
|
|
;; `level'
|
|
;; While processing the directory the procedures tracks how
|
|
;; many directories have been examined to find the current
|
|
;; item. This nesting level is 0 for the item given starting
|
|
;; item (file or directory) and is incremented by one for each
|
|
;; entered directory.
|
|
;;
|
|
;; * Procedure: (ftw filename proc . options)
|
|
;; Do a filesystem tree walk starting at FILENAME using PROC.
|
|
;;
|
|
;; The `ftw' procedure calls the callback procedure given in the
|
|
;; parameter PROC for every item which is found in the directory
|
|
;; specified by FILENAME and all directories below. The procedure
|
|
;; follows symbolic links if necessary but does not process an item
|
|
;; twice. If FILENAME names no directory this item is the only
|
|
;; object reported by calling the callback procedure.
|
|
;;
|
|
;; The filename given to the callback procedure is constructed by
|
|
;; taking the FILENAME parameter and appending the names of all
|
|
;; passed directories and then the local file name. So the
|
|
;; callback procedure can use this parameter to access the file.
|
|
;; Before the callback procedure is called `ftw' calls `stat' for
|
|
;; this file and passes the information up to the callback
|
|
;; procedure. If this `stat' call was not successful the failure is
|
|
;; indicated by setting the flag argument of the callback procedure
|
|
;; to `invalid-stat'. Otherwise the flag is set according to the
|
|
;; description given in the description of `__ftw_proc_t' above.
|
|
;;
|
|
;; The callback procedure is expected to return non-#f to indicate
|
|
;; that no error occurred and the processing should be continued.
|
|
;; If an error occurred in the callback procedure or the call to
|
|
;; `ftw' shall return immediately the callback procedure can return
|
|
;; #f. This is the only correct way to stop the procedure. The
|
|
;; program must not use `throw' or similar techniques to continue
|
|
;; the program in another place. [Can we relax this? --ttn]
|
|
;;
|
|
;; The return value of the `ftw' procedure is #t if all callback
|
|
;; procedure calls returned #t and all actions performed by the
|
|
;; `ftw' succeeded. If some procedure call failed (other than
|
|
;; calling `stat' on an item) the procedure returns #f. If a
|
|
;; callback procedure returns a value other than #t this value is
|
|
;; returned as the return value of `ftw'.
|
|
;;
|
|
;; * Procedure: (nftw filename proc . control-flags)
|
|
;; Do a new-style filesystem tree walk starting at FILENAME using PROC.
|
|
;; Various optional CONTROL-FLAGS alter the default behavior.
|
|
;;
|
|
;; The `nftw' procedures works like the `ftw' procedures. It calls
|
|
;; the callback procedure PROC for all items it finds in the
|
|
;; directory FILENAME and below.
|
|
;;
|
|
;; The differences are that for one the callback procedure is of a
|
|
;; different type. It takes also `base' and `level' parameters as
|
|
;; described above.
|
|
;;
|
|
;; The second difference is that `nftw' takes additional optional
|
|
;; arguments which are zero or more of the following symbols:
|
|
;;
|
|
;; physical'
|
|
;; While traversing the directory symbolic links are not
|
|
;; followed. I.e., if this flag is given symbolic links are
|
|
;; reported using the `symlink' value for the type parameter
|
|
;; to the callback procedure. Please note that if this flag is
|
|
;; used the appearance of `symlink' in a callback procedure
|
|
;; does not mean the referenced file does not exist. To
|
|
;; indicate this the extra value `stale-symlink' exists.
|
|
;;
|
|
;; mount'
|
|
;; The callback procedure is only called for items which are on
|
|
;; the same mounted filesystem as the directory given as the
|
|
;; FILENAME parameter to `nftw'.
|
|
;;
|
|
;; chdir'
|
|
;; If this flag is given the current working directory is
|
|
;; changed to the directory containing the reported object
|
|
;; before the callback procedure is called.
|
|
;;
|
|
;; depth'
|
|
;; If this option is given the procedure visits first all files
|
|
;; and subdirectories before the callback procedure is called
|
|
;; for the directory itself (depth-first processing). This
|
|
;; also means the type flag given to the callback procedure is
|
|
;; `directory-processed' and not `directory'.
|
|
;;
|
|
;; The return value is computed in the same way as for `ftw'.
|
|
;; `nftw' returns #t if no failure occurred in `nftw' and all
|
|
;; callback procedure call return values are also #t. For internal
|
|
;; errors such as memory problems the error `ftw-error' is thrown.
|
|
;; If the return value of a callback invocation is not #t this
|
|
;; very same value is returned.
|
|
|
|
;;; Code:
|
|
|
|
(define-module (ice-9 ftw)
|
|
:export (ftw nftw))
|
|
|
|
(define (directory-files dir)
|
|
(let ((dir-stream (opendir dir)))
|
|
(let loop ((new (readdir dir-stream))
|
|
(acc '()))
|
|
(if (eof-object? new)
|
|
(begin
|
|
(closedir dir-stream)
|
|
acc)
|
|
(loop (readdir dir-stream)
|
|
(if (or (string=? "." new) ;;; ignore
|
|
(string=? ".." new)) ;;; ignore
|
|
acc
|
|
(cons new acc)))))))
|
|
|
|
(define (pathify . nodes)
|
|
(let loop ((nodes nodes)
|
|
(result ""))
|
|
(if (null? nodes)
|
|
(or (and (string=? "" result) "")
|
|
(substring result 1 (string-length result)))
|
|
(loop (cdr nodes) (string-append result "/" (car nodes))))))
|
|
|
|
(define (abs? filename)
|
|
(char=? #\/ (string-ref filename 0)))
|
|
|
|
;; `visited?-proc' returns a test procedure VISITED? which when called as
|
|
;; (VISITED? stat-obj) returns #f the first time a distinct file is seen,
|
|
;; then #t on any subsequent sighting of it.
|
|
;;
|
|
;; stat:dev and stat:ino together uniquely identify a file (see "Attribute
|
|
;; Meanings" in the glibc manual). Often there'll be just one dev, and
|
|
;; usually there's just a handful mounted, so the strategy here is a small
|
|
;; hash table indexed by dev, containing hash tables indexed by ino.
|
|
;;
|
|
;; It'd be possible to make a pair (dev . ino) and use that as the key to a
|
|
;; single hash table. It'd use an extra pair for every file visited, but
|
|
;; might be a little faster if it meant less scheme code.
|
|
;;
|
|
(define (visited?-proc size)
|
|
(let ((dev-hash (make-hash-table 7)))
|
|
(lambda (s)
|
|
(and s
|
|
(let ((ino-hash (hashv-ref dev-hash (stat:dev s)))
|
|
(ino (stat:ino s)))
|
|
(or ino-hash
|
|
(begin
|
|
(set! ino-hash (make-hash-table size))
|
|
(hashv-set! dev-hash (stat:dev s) ino-hash)))
|
|
(or (hashv-ref ino-hash ino)
|
|
(begin
|
|
(hashv-set! ino-hash ino #t)
|
|
#f)))))))
|
|
|
|
(define (stat-dir-readable?-proc uid gid)
|
|
(let ((uid (getuid))
|
|
(gid (getgid)))
|
|
(lambda (s)
|
|
(let* ((perms (stat:perms s))
|
|
(perms-bit-set? (lambda (mask)
|
|
(not (= 0 (logand mask perms))))))
|
|
(or (and (= uid (stat:uid s))
|
|
(perms-bit-set? #o400))
|
|
(and (= gid (stat:gid s))
|
|
(perms-bit-set? #o040))
|
|
(perms-bit-set? #o004))))))
|
|
|
|
(define (stat&flag-proc dir-readable? . control-flags)
|
|
(let* ((directory-flag (if (memq 'depth control-flags)
|
|
'directory-processed
|
|
'directory))
|
|
(stale-symlink-flag (if (memq 'nftw-style control-flags)
|
|
'stale-symlink
|
|
'symlink))
|
|
(physical? (memq 'physical control-flags))
|
|
(easy-flag (lambda (s)
|
|
(let ((type (stat:type s)))
|
|
(if (eq? 'directory type)
|
|
(if (dir-readable? s)
|
|
directory-flag
|
|
'directory-not-readable)
|
|
'regular)))))
|
|
(lambda (name)
|
|
(let ((s (false-if-exception (lstat name))))
|
|
(cond ((not s)
|
|
(values s 'invalid-stat))
|
|
((eq? 'symlink (stat:type s))
|
|
(let ((s-follow (false-if-exception (stat name))))
|
|
(cond ((not s-follow)
|
|
(values s stale-symlink-flag))
|
|
((and s-follow physical?)
|
|
(values s 'symlink))
|
|
((and s-follow (not physical?))
|
|
(values s-follow (easy-flag s-follow))))))
|
|
(else (values s (easy-flag s))))))))
|
|
|
|
(define (clean name)
|
|
(let ((last-char-index (1- (string-length name))))
|
|
(if (char=? #\/ (string-ref name last-char-index))
|
|
(substring name 0 last-char-index)
|
|
name)))
|
|
|
|
(define (ftw filename proc . options)
|
|
(let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr)
|
|
(else 211))))
|
|
(stat&flag (stat&flag-proc
|
|
(stat-dir-readable?-proc (getuid) (getgid)))))
|
|
(letrec ((go (lambda (fullname)
|
|
(call-with-values (lambda () (stat&flag fullname))
|
|
(lambda (s flag)
|
|
(or (visited? s)
|
|
(let ((ret (proc fullname s flag))) ; callback
|
|
(or (eq? #t ret)
|
|
(throw 'ftw-early-exit ret))
|
|
(and (eq? 'directory flag)
|
|
(for-each
|
|
(lambda (child)
|
|
(go (pathify fullname child)))
|
|
(directory-files fullname)))
|
|
#t)))))))
|
|
(catch 'ftw-early-exit
|
|
(lambda () (go (clean filename)))
|
|
(lambda (key val) val)))))
|
|
|
|
(define (nftw filename proc . control-flags)
|
|
(let* ((od (getcwd)) ; orig dir
|
|
(odev (let ((s (false-if-exception (lstat filename))))
|
|
(if s (stat:dev s) -1)))
|
|
(same-dev? (if (memq 'mount control-flags)
|
|
(lambda (s) (= (stat:dev s) odev))
|
|
(lambda (s) #t)))
|
|
(base-sub (lambda (name base) (substring name 0 base)))
|
|
(maybe-cd (if (memq 'chdir control-flags)
|
|
(if (abs? filename)
|
|
(lambda (fullname base)
|
|
(or (= 0 base)
|
|
(chdir (base-sub fullname base))))
|
|
(lambda (fullname base)
|
|
(chdir
|
|
(pathify od (base-sub fullname base)))))
|
|
(lambda (fullname base) #t)))
|
|
(maybe-cd-back (if (memq 'chdir control-flags)
|
|
(lambda () (chdir od))
|
|
(lambda () #t)))
|
|
(depth-first? (memq 'depth control-flags))
|
|
(visited? (visited?-proc
|
|
(cond ((memq 'hash-size control-flags) => cadr)
|
|
(else 211))))
|
|
(has-kids? (if depth-first?
|
|
(lambda (flag) (eq? flag 'directory-processed))
|
|
(lambda (flag) (eq? flag 'directory))))
|
|
(stat&flag (apply stat&flag-proc
|
|
(stat-dir-readable?-proc (getuid) (getgid))
|
|
(cons 'nftw-style control-flags))))
|
|
(letrec ((go (lambda (fullname base level)
|
|
(call-with-values (lambda () (stat&flag fullname))
|
|
(lambda (s flag)
|
|
(letrec ((self (lambda ()
|
|
(maybe-cd fullname base)
|
|
;; the callback
|
|
(let ((ret (proc fullname s flag
|
|
base level)))
|
|
(maybe-cd-back)
|
|
(or (eq? #t ret)
|
|
(throw 'nftw-early-exit ret)))))
|
|
(kids (lambda ()
|
|
(and (has-kids? flag)
|
|
(for-each
|
|
(lambda (child)
|
|
(go (pathify fullname child)
|
|
(1+ (string-length
|
|
fullname))
|
|
(1+ level)))
|
|
(directory-files fullname))))))
|
|
(or (visited? s)
|
|
(not (same-dev? s))
|
|
(if depth-first?
|
|
(begin (kids) (self))
|
|
(begin (self) (kids)))))))
|
|
#t)))
|
|
(let ((ret (catch 'nftw-early-exit
|
|
(lambda () (go (clean filename) 0 0))
|
|
(lambda (key val) val))))
|
|
(chdir od)
|
|
ret))))
|
|
|
|
;;; ftw.scm ends here
|