diff options
author | Ludovic Courtès <ludo@gnu.org> | 2012-01-08 16:06:35 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2012-01-08 16:16:21 +0100 |
commit | be96155b508d220efe6f419d7743cf39744ee47c (patch) | |
tree | e7e0d5acbf3807c8c4b3b433b9c3b81815cf423d /test-suite/tests | |
parent | 9a38439301aac35961e8f7e316cd02a589b5956f (diff) | |
download | guile-be96155b508d220efe6f419d7743cf39744ee47c.tar.gz |
ftw: Add an `error' parameter to `file-system-fold'.
* module/ice-9/ftw.scm (errno-if-exception): New macro.
(file-system-fold): Add an `error' parameter. Wrap `opendir' and STAT
calls in `errno-if-exception' and call ERROR when appropriate.
(file-system-tree): Provide an `error' procedure. Return #f when
FILE-NAME is unreadable.
(scandir): Provide an `error' procedure.
* test-suite/tests/ftw.test (%top-builddir): New variable.
(make-file-tree, delete-file-tree): New procedures.
(with-file-tree): New macro.
("file-system-fold"): Update tests to add an `error' procedure.
["ENOENT", "EACCES", "dangling symlink and lstat", "dangling symlink
and stat"]: New tests.
("file-system-tree")["ENOENT"]: New test.
("scandir")["EACCES"]: New test.
* doc/ref/misc-modules.texi (File Tree Walk): Update `file-system-fold'
documentation.
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/ftw.test | 147 |
1 files changed, 138 insertions, 9 deletions
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index fa179d400..be983a16a 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -1,6 +1,6 @@ ;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*- ;;;; -;;;; Copyright 2006, 2011 Free Software Foundation, Inc. +;;;; Copyright 2006, 2011, 2012 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 @@ -81,12 +81,71 @@ ;;; `file-system-fold' & co. ;;; +(define %top-builddir + (canonicalize-path (getcwd))) + (define %top-srcdir (assq-ref %guile-build-info 'top_srcdir)) (define %test-dir (string-append %top-srcdir "/test-suite")) +(define (make-file-tree dir tree) + "Make file system TREE at DIR." + (define (touch file) + (call-with-output-file file + (cut display "" <>))) + + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body)) + (('directory name (? integer? mode) (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body) + (chmod (scope name) mode)) + ((file) + (touch (scope file))) + ((file (? integer? mode)) + (touch (scope file)) + (chmod (scope file) mode)) + ((from '-> to) + (symlink to (scope from)))))) + +(define (delete-file-tree dir tree) + "Delete file TREE from DIR." + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + (('directory name (? integer? mode) (body ...)) + (chmod (scope name) #o755) ; make sure it can be entered + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + ((from '-> _) + (delete-file (scope from))) + ((file _ ...) + (delete-file (scope file)))))) + +(define-syntax-rule (with-file-tree dir tree body ...) + (dynamic-wind + (lambda () + (make-file-tree dir tree)) + (lambda () + body ...) + (lambda () + (delete-file-tree dir tree)))) + (with-test-prefix "file-system-fold" (pass-if "test-suite" @@ -98,10 +157,11 @@ (leaf (lambda (n s r) (cons `(leaf ,n) r))) (down (lambda (n s r) (cons `(down ,n) r))) (up (lambda (n s r) (cons `(up ,n) r))) - (skip (lambda (n s r) (cons `(skip ,n) r)))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n) r)))) (define seq (reverse - (file-system-fold enter? leaf down up skip '() %test-dir))) + (file-system-fold enter? leaf down up skip error '() %test-dir))) (match seq ((('down (? (cut string=? <> %test-dir))) @@ -123,8 +183,9 @@ (leaf (lambda (n s r) (cons `(leaf ,n) r))) (down (lambda (n s r) (cons `(down ,n) r))) (up (lambda (n s r) (cons `(up ,n) r))) - (skip (lambda (n s r) (cons `(skip ,n) r)))) - (equal? (file-system-fold enter? leaf down up skip '() %test-dir) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n) r)))) + (equal? (file-system-fold enter? leaf down up skip error '() %test-dir) `((skip , %test-dir))))) (pass-if "test-suite/lib.scm (flat file)" @@ -133,9 +194,67 @@ (down (lambda (n s r) (cons `(down ,n) r))) (up (lambda (n s r) (cons `(up ,n) r))) (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n) r))) (name (string-append %test-dir "/lib.scm"))) - (equal? (file-system-fold enter? leaf down up skip '() name) - `((leaf ,name)))))) + (equal? (file-system-fold enter? leaf down up skip error '() name) + `((leaf ,name))))) + + (pass-if "ENOENT" + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name "/.does-not-exist.")) + (equal? (file-system-fold enter? leaf down up skip error '() name) + `((error ,name ,ENOENT))))) + + (pass-if "EACCES" + (with-file-tree %top-builddir '(directory "test-EACCES" #o000 + (("a") ("b"))) + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name (string-append %top-builddir "/test-EACCES"))) + (equal? (file-system-fold enter? leaf down up skip error '() name) + `((error ,name ,EACCES)))))) + + (pass-if "dangling symlink and lstat" + (with-file-tree %top-builddir '(directory "test-dangling" + (("dangling" -> "xxx"))) + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name (string-append %top-builddir "/test-dangling"))) + (equal? (file-system-fold enter? leaf down up skip error '() + name) + `((up ,name) + (leaf ,(string-append name "/dangling")) + (down ,name)))))) + + (pass-if "dangling symlink and stat" + ;; Same as above, but using `stat' instead of `lstat'. + (with-file-tree %top-builddir '(directory "test-dangling" + (("dangling" -> "xxx"))) + (let ((enter? (lambda (n s r) #t)) + (leaf (lambda (n s r) (cons `(leaf ,n) r))) + (down (lambda (n s r) (cons `(down ,n) r))) + (up (lambda (n s r) (cons `(up ,n) r))) + (skip (lambda (n s r) (cons `(skip ,n) r))) + (error (lambda (n s e r) (cons `(error ,n ,e) r))) + (name (string-append %top-builddir "/test-dangling"))) + (equal? (file-system-fold enter? leaf down up skip error '() + name stat) + `((up ,name) + (error ,(string-append name "/dangling") ,ENOENT) + (down ,name))))))) (with-test-prefix "file-system-tree" @@ -165,7 +284,10 @@ (lset-intersection string=? files expected) expected))) (_ #f)) - children))))) + children)))) + + (pass-if "ENOENT" + (not (file-system-tree "/.does-not-exist.")))) (with-test-prefix "scandir" @@ -188,4 +310,11 @@ #t)))) (pass-if "flat file" - (not (scandir (string-append %test-dir "/Makefile.am"))))) + (not (scandir (string-append %test-dir "/Makefile.am")))) + + (pass-if "EACCES" + (not (scandir "/.does-not-exist.")))) + +;;; Local Variables: +;;; eval: (put 'with-file-tree 'scheme-indent-function 2) +;;; End: |