diff options
-rw-r--r-- | module/ice-9/ftw.scm | 42 | ||||
-rw-r--r-- | 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 203b5462c..ac4dd608a 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 87e8c84d1..4d210dd7a 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")) |