mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

test-suite: Skip EACCES' test of file-system-fold' when run as root.

Browse source 
* test-suite/tests/ftw.test ("file-system-fold")["EACCES"]: Use
  `pass-if-equal'.  Throw `unresolved' when run as root.
  Reported by Andreas Enge <andreas@enge.fr> at
  <http://lists.gnu.org/archive/html/bug-guix/2012-12/msg00073.html>.
This commit is contained in:
Ludovic Courtès 2012-12-10 23:16:13 +01:00
parent cc94810708
commit 9977b31643
1 changed files with 16 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

28
test-suite/tests/ftw.test
View file

@ -214,18 +214,22 @@
(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))))))
(let ((name (string-append %top-builddir "/test-EACCES")))
(pass-if-equal "EACCES"
`((error ,name ,EACCES))
(if (zero? (getuid))
;; When run as root, this test would fail because root can
;; list the contents of #o000 directories.
(throw 'unresolved)
(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))))
(file-system-fold enter? leaf down up skip error '() name))))))
(pass-if "dangling symlink and lstat"
(with-file-tree %top-builddir '(directory "test-dangling"