Re: join the guile development

[thi]

   From: Marco Maggesi <address@hidden>
   Date: 27 Sep 2000 18:37:11 +0200

   I have found an item about

     "Directory walker with list of predicates".

   Are there people already working on it or does this have
   been implemented?  Are there further ideas, suggestions,
   code, in addition to what discussed in the above mentioned
   web page?

in GNU libc there are the functions `ftw' and `nftw', probably standing
for "filesystem tree walk" and "new filesystem tree walk".  i've written
a guile scheme analog to `ftw' available in directory:

  http://www.glug.org/people/ttn/software/ttn-pers-scheme/

see module `(ttn ftw)'.  the code is incomplete so i'm actually in the
process of rewriting `ftw' and implementing `nftw' for a planned release
sometime next week.  in the meantime, for your convenience, see below
for a snapshot of the work in progress.

(this code is not part of guile.)

thi


____________________________
;;; ttn/ftw.scm --- filesystem tree walk

;; $State: Exp $:$Name:  $
;;
;; Copyright (C) 2000 Thien-Thi Nguyen
;; This file is part of ttn's personal scheme library, released under GNU
;; GPL with ABSOLUTELY NO WARRANTY.  See the file COPYING for details.

;;; Commentary:

;; The following description was adapted from the libc info page, w/
;; significant modifications by ttn for a more "Schemey" interface.
;; Most noticible are the inlining of `struct FTW *' parameters `base'
;; and `level' and the omission of `descriptors' parameters.

;;    The X/Open specification defines two functions to process whole
;; hierarchies of directories and the contained files.  Both functions
;; of this `ftw' family take as one of the arguments a callback function
;; which must be of these types.
;;
;;  - Data Type: __ftw_func_t
;;           (lambda (filename statinfo flag) ...) => status
;;
;;      Type for callback functions given to the `ftw' function.  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
;;           function means the referenced file does not exist.  The
;;           situation for `nftw' is different.
;;
;;  - Data Type: __nftw_func_t
;;           (lambda (filename statinfo flag base level) ...) => status
;;
;;      The first three arguments have the same as for the
;;      `__ftw_func_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 function 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 functions 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.
;;
;;  - Function: ftw filename func => status
;;      The `ftw' function calls the callback function given in the
;;      parameter FUNC for every item which is found in the directory
;;      specified by FILENAME and all directories below.  The function
;;      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 function.
;;
;;      The filename given to the callback function is constructed by
;;      taking the FILENAME parameter and appending the names of all
;;      passed directories and then the local file name.  So the
;;      callback function can use this parameter to access the file.
;;      Before the callback function is called `ftw' calls `stat' for
;;      this file and passes the information up to the callback
;;      function.  If this `stat' call was not successful the failure is
;;      indicated by setting the flag argument of the callback function
;;      to `invalid-stat'.  Otherwise the flag is set according to the
;;      description given in the description of `__ftw_func_t' above.
;;
;;      The callback function 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 function or the call to
;;      `ftw' shall return immediately the callback function can return
;;      #f.  This is the only correct way to stop the function.  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' function is #t if all callback
;;      function calls returned #t and all actions performed by the
;;      `ftw' succeeded.  If some function call failed (other than
;;      calling `stat' on an item) the function returns #f.  If a
;;      callback function returns a value other than #t this value is
;;      returned as the return value of `ftw'.
;;
;;  - Function: nftw filename func flag => status
;;      The `nftw' functions works like the `ftw' functions.  It calls
;;      the callback function FUNC for all items it finds in the
;;      directory FILENAME and below.
;;
;;      The differences are that for one the callback function is of a
;;      different type.  It takes also `base' and `level' parameters as
;;      described above.
;;
;;      The second difference is that `nftw' takes an additional third
;;      argument which is a list of 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 function.  Please note that if this flag is
;;           used the appearance of `symlink' in a callback function
;;           does not mean the referenced file does not exist.  To
;;           indicate this the extra value `stale-symlink' exists.
;;
;;     `mount'
;;           The callback function 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 function is called.
;;
;;     `depth'
;;           If this option is given the function visits first all files
;;           and subdirectories before the callback function is called
;;           for the directory itself (depth-first processing).  This
;;           also means the type flag given to the callback function 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 function 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 (ttn ftw)
  :use-module (ttn dirutils))

(define (old-possibly-ready-to-retire-safe-stat name)
  (catch 'system-error
         (lambda () (stat name))
         (lambda (key . args) #f)))

(define (safe-stat name)
  (false-if-exception (stat name)))

(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 (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?)
  (lambda (s)
    (if (not s)
        'invalid-stat
        (let ((type (stat:type s)))
          (if (eq? 'directory type)
              (if (dir-readable? s)
                  'directory
                  'directory-not-readable)
              (if (memq type '(regular
                               ;; ttn extension
                               symlink
                               block-special
                               char-special
                               fifo
                               socket))
                  type
                  (error "stat->flag incomplete!")))))))

(define (stat->nflags-proc dir-readable?) ; STUB
  (error "`stat->nflags-proc' not yet implemented"))

(define (ftw filename func)             ; a la libc
  (let* ((dir-readable? (stat-dir-readable?-proc (getuid) (getgid)))
         (stat->flag (stat->flag-proc dir-readable?))
         (abs? (lambda (filename)
                 (string=? "/" (substring filename 0 1))))
         (visited '())                  ; todo: use hash
         (visited? (lambda (s)
                     (and s (let ((ino (stat:ino s)))
                              (or (memq ino visited)
                                  (begin
                                    (set! visited (cons ino visited))
                                    #f)))))))
    (letrec ((go (lambda (fullname)
                   (let* ((s (safe-stat fullname))
                          (flag (stat->flag s)))
                     (or (visited? s)
                         (let ((ret (func fullname s flag))) ; callback
                           (and (not ret)
                                (throw 'ftw-early-exit #f))
                           (or (and (eq? 'directory flag)
                                    (begin
                                      (for-each
                                       (lambda (child)
                                         (go (pathify fullname child)))
                                       (filtered-files not-dot-not-dotdot
                                                       fullname))
                                      #t))
                               ret)))))))
      (catch 'ftw-early-exit
             (lambda () (go filename))
             (lambda (key . args) #f)))))

(define (nftw filename func control-flags) ; STUB
  (error "`nftw' not yet implemented"))

;;;---------------------------------------------------------------------------
;;; testing

(and #f
     (define (test-ftw filename)
       (ftw filename
            (lambda (name stat flags)
              (display ";;; ") (write-line (list name flags))
              (if (string=? "zdgood/vlsi/cavd" name)
                  #f
                  (list name flags)))))
     )

;;;---------------------------------------------------------------------------
;;; export

(export safe-stat ftw nftw)

;;; ttn/ftw.scm ends here