[Guile-commits] 06/11: ice-9 ftw: handle non-working inodes

[Mike Gran]

mike121 pushed a commit to branch mingw-guile-3.0
in repository guile.

commit 88ac9308dd6ba1e17543023f9fccb0f8601ef177
Author: Michael Gran <spk121@yahoo.com>
AuthorDate: Mon Apr 16 20:57:12 2018 -0700

    ice-9 ftw: handle non-working inodes
    
    * module/ice-9/ftw.scm (visited?-proc): accept filename for string hash
      (file-system-fold): use string hash if ino = 0
      (ftw): use new visited?-proc
    * test-suite/tests/ftw.test (visited?-proc valid inodes): add filenames to 
visited?-proc calls
      (visited?-proc broken inodes): new tests
      (%top-srcdir): canonicalize-path
---
 module/ice-9/ftw.scm      | 42 +++++++++++++++++++++++++-----------
 test-suite/tests/ftw.test | 55 ++++++++++++++++++++++++++++++++---------------
 2 files changed, 67 insertions(+), 30 deletions(-)

diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 203b546..ac4dd60 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -243,16 +243,22 @@
 ;; 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.
 ;;
+;; On some file systems, stat:ino is always zero.  In that case,
+;; a string hash of the full file name is used.
+;;
 ;; 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)
+    (lambda (s name)
       (and s
-          (let ((ino-hash (hashv-ref dev-hash (stat:dev s)))
-                (ino      (stat:ino s)))
+          (let* ((ino-hash (hashv-ref dev-hash (stat:dev s)))
+                  (%ino     (stat:ino s))
+                  (ino      (if (= 0 %ino)
+                                (string-hash name)
+                                %ino)))
             (or ino-hash
                 (begin
                   (set! ino-hash (make-hash-table size))
@@ -318,7 +324,7 @@
     (letrec ((go (lambda (fullname)
                    (call-with-values (lambda () (stat&flag fullname))
                      (lambda (s flag)
-                       (or (visited? s)
+                       (or (visited? s fullname)
                            (let ((ret (proc fullname s flag))) ; callback
                              (or (eq? #t ret)
                                  (throw 'ftw-early-exit ret))
@@ -383,7 +389,7 @@
                                                          fullname))
                                                     (1+ level)))
                                               (directory-files fullname))))))
-                         (or (visited? s)
+                         (or (visited? s fullname)
                              (not (same-dev? s))
                              (if depth-first?
                                  (begin (kids) (self))
@@ -423,11 +429,21 @@ Return the result of these successive applications.
 When FILE-NAME names a flat file, (LEAF PATH STAT INIT) is returned.
 The optional STAT parameter defaults to `lstat'."
 
-  (define (mark v s)
-    (vhash-cons (cons (stat:dev s) (stat:ino s)) #t v))
-
-  (define (visited? v s)
-    (vhash-assoc (cons (stat:dev s) (stat:ino s)) v))
+  ;; Use drive and inode number as a hash key.  If the filesystem
+  ;; doesn't use inodes, fall back to a string hash.
+  (define (mark v s fname)
+    (vhash-cons (cons (stat:dev s)
+                      (if (= 0 (stat:ino s))
+                          (string-hash fname)
+                          (stat:ino s)))
+                #t v))
+
+  (define (visited? v s fname)
+    (vhash-assoc (cons (stat:dev s)
+                       (if (= 0 (stat:ino s))
+                           (string-hash fname)
+                           (stat:ino s)))
+                 v))
 
   (let loop ((name     file-name)
              (path     "")
@@ -444,12 +460,12 @@ The optional STAT parameter defaults to `lstat'."
      ((integer? dir-stat)
       ;; FILE-NAME is not readable.
       (error full-name #f dir-stat result))
-     ((visited? visited dir-stat)
+     ((visited? visited dir-stat full-name)
       (values result visited))
      ((eq? 'directory (stat:type dir-stat)) ; true except perhaps the 1st time
       (if (enter? full-name dir-stat result)
           (let ((dir     (errno-if-exception (opendir full-name)))
-                (visited (mark visited dir-stat)))
+                (visited (mark visited dir-stat full-name)))
             (cond
              ((directory-stream? dir)
               (let liip ((entry   (readdir dir))
@@ -496,7 +512,7 @@ The optional STAT parameter defaults to `lstat'."
               (values (error full-name dir-stat dir result)
                       visited))))
           (values (skip full-name dir-stat result)
-                  (mark visited dir-stat))))
+                  (mark visited dir-stat full-name))))
      (else
       ;; Caller passed a FILE-NAME that names a flat file, not a directory.
       (leaf full-name dir-stat result)))))
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index 87e8c84..4d210dd 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -53,28 +53,49 @@
         (visited? (visited?-proc 97))
         (s (stat "/")))
 
-    (define (try-visited? dev ino)
+    (define (try-visited? dev ino fname)
       (stat:dev! s dev)
       (stat:ino! s ino)
-      (visited? s))
+      (visited? s fname))
 
-    (pass-if "0 0 - 1st" (eq? #f (try-visited? 0 0)))
-    (pass-if "0 0 - 2nd" (eq? #t (try-visited? 0 0)))
-    (pass-if "0 0 - 3rd" (eq? #t (try-visited? 0 0)))
+    (with-test-prefix "valid inodes"
 
-    (pass-if "0 1" (eq? #f (try-visited? 0 1)))
-    (pass-if "0 2" (eq? #f (try-visited? 0 2)))
-    (pass-if "0 3" (eq? #f (try-visited? 0 3)))
+      (pass-if "0 1 - 1st" (eq? #f (try-visited? 0 1 "0.1")))
+      (pass-if "0 1 - 2nd" (eq? #t (try-visited? 0 1 "0.1")))
+      (pass-if "0 1 - 3rd" (eq? #t (try-visited? 0 1 "0.1")))
 
-    (pass-if "5 5" (eq? #f (try-visited? 5 5)))
-    (pass-if "5 7" (eq? #f (try-visited? 5 7)))
-    (pass-if "7 5" (eq? #f (try-visited? 7 5)))
-    (pass-if "7 7" (eq? #f (try-visited? 7 7)))
+      (pass-if "0 2" (eq? #f (try-visited? 0 2 "0.2")))
+      (pass-if "0 3" (eq? #f (try-visited? 0 3 "0.3")))
+      (pass-if "0 4" (eq? #f (try-visited? 0 4 "0.4")))
 
-    (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5)))
-    (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7)))
-    (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5)))
-    (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7)))))
+      (pass-if "5 5" (eq? #f (try-visited? 5 5 "5.5")))
+      (pass-if "5 7" (eq? #f (try-visited? 5 7 "5.7")))
+      (pass-if "7 5" (eq? #f (try-visited? 7 5 "7.5")))
+      (pass-if "7 7" (eq? #f (try-visited? 7 7 "7.7")))
+
+      (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5 "5.5")))
+      (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7 "5.7")))
+      (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5 "7.5")))
+      (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7 "7.7"))))
+
+    (with-test-prefix "broken inodes"
+      (pass-if "0 1 - 1st" (eq? #f (try-visited? 0 0 "0.1")))
+      (pass-if "0 1 - 2nd" (eq? #t (try-visited? 0 0 "0.1")))
+      (pass-if "0 1 - 3rd" (eq? #t (try-visited? 0 0 "0.1")))
+
+      (pass-if "0 2" (eq? #f (try-visited? 0 0 "0.2")))
+      (pass-if "0 3" (eq? #f (try-visited? 0 0 "0.3")))
+      (pass-if "0 4" (eq? #f (try-visited? 0 0 "0.4")))
+
+      (pass-if "5 5" (eq? #f (try-visited? 5 0 "5.5")))
+      (pass-if "5 7" (eq? #f (try-visited? 5 0 "5.7")))
+      (pass-if "7 5" (eq? #f (try-visited? 7 0 "7.5")))
+      (pass-if "7 7" (eq? #f (try-visited? 7 0 "7.7")))
+
+      (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 0 "5.5")))
+      (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 0 "5.7")))
+      (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 0 "7.5")))
+      (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 0 "7.7"))))))
 
 
 ;;;
@@ -85,7 +106,7 @@
   (canonicalize-path (getcwd)))
 
 (define %top-srcdir
-  (assq-ref %guile-build-info 'top_srcdir))
+  (canonicalize-path (assq-ref %guile-build-info 'top_srcdir)))
 
 (define %test-dir
   (string-append %top-srcdir "/test-suite"))