mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
be96155b50
* 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.
320 lines
12 KiB
Scheme
320 lines
12 KiB
Scheme
;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*-
|
||
;;;;
|
||
;;;; 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
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
(define-module (test-suite test-ice-9-ftw)
|
||
#:use-module (test-suite lib)
|
||
#:use-module (ice-9 ftw)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-26))
|
||
|
||
|
||
;; the procedure-source checks here ensure the vector indexes we write match
|
||
;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match
|
||
;; libguile/filesys.c of course)
|
||
|
||
(define (stat:dev! st dev)
|
||
(vector-set! st 0 dev))
|
||
(define (stat:ino! st ino)
|
||
(vector-set! st 1 ino))
|
||
|
||
(let* ((s (stat "/"))
|
||
(i (stat:ino s))
|
||
(d (stat:dev s)))
|
||
(stat:ino! s (1+ i))
|
||
(stat:dev! s (1+ d))
|
||
(if (not (and (= (stat:ino s) (1+ i))
|
||
(= (stat:dev s) (1+ d))))
|
||
(error "unexpected definitions of stat:dev and stat:ino")))
|
||
|
||
;;
|
||
;; visited?-proc
|
||
;;
|
||
|
||
(with-test-prefix "visited?-proc"
|
||
|
||
;; normally internal-only
|
||
(let* ((visited?-proc (@@ (ice-9 ftw) visited?-proc))
|
||
(visited? (visited?-proc 97))
|
||
(s (stat "/")))
|
||
|
||
(define (try-visited? dev ino)
|
||
(stat:dev! s dev)
|
||
(stat:ino! s ino)
|
||
(visited? s))
|
||
|
||
(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)))
|
||
|
||
(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 "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 "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)))))
|
||
|
||
|
||
;;;
|
||
;;; `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"
|
||
(let ((enter? (lambda (n s r)
|
||
;; Enter only `test-suite/tests/'.
|
||
(if (member `(down ,%test-dir) r)
|
||
(string=? (basename n) "tests")
|
||
(string=? (basename n) "test-suite"))))
|
||
(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) r))))
|
||
(define seq
|
||
(reverse
|
||
(file-system-fold enter? leaf down up skip error '() %test-dir)))
|
||
|
||
(match seq
|
||
((('down (? (cut string=? <> %test-dir)))
|
||
between ...
|
||
('up (? (cut string=? <> %test-dir))))
|
||
(and (any (match-lambda (('leaf (= basename "lib.scm")) #t) (_ #f))
|
||
between)
|
||
(any (match-lambda (('down (= basename "tests")) #t) (_ #f))
|
||
between)
|
||
(any (match-lambda (('leaf (= basename "alist.test")) #t) (_ #f))
|
||
between)
|
||
(any (match-lambda (('up (= basename "tests")) #t) (_ #f))
|
||
between)
|
||
(any (match-lambda (('skip (= basename "vm")) #t) (_ #f))
|
||
between))))))
|
||
|
||
(pass-if "test-suite (never enter)"
|
||
(let ((enter? (lambda (n s r) #f))
|
||
(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) r))))
|
||
(equal? (file-system-fold enter? leaf down up skip error '() %test-dir)
|
||
`((skip , %test-dir)))))
|
||
|
||
(pass-if "test-suite/lib.scm (flat file)"
|
||
(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) r)))
|
||
(name (string-append %test-dir "/lib.scm")))
|
||
(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"
|
||
|
||
(pass-if "test-suite (never enter)"
|
||
(match (file-system-tree %test-dir (lambda (n s) #f))
|
||
(("test-suite" (= stat:type 'directory)) ; no children
|
||
#t)))
|
||
|
||
(pass-if "test-suite/*"
|
||
(match (file-system-tree %test-dir (lambda (n s)
|
||
(string=? n %test-dir)))
|
||
(("test-suite" (= stat:type 'directory) children ...)
|
||
(any (match-lambda
|
||
(("tests" (= stat:type 'directory)) ; no children
|
||
#t)
|
||
(_ #f))
|
||
children))))
|
||
|
||
(pass-if "test-suite (recursive)"
|
||
(match (file-system-tree %test-dir)
|
||
(("test-suite" (= stat:type 'directory) children ...)
|
||
(any (match-lambda
|
||
(("tests" (= stat:type 'directory) (= car files) ...)
|
||
(let ((expected '("alist.test" "bytevectors.test"
|
||
"ftw.test" "gc.test" "vlist.test")))
|
||
(lset= string=?
|
||
(lset-intersection string=? files expected)
|
||
expected)))
|
||
(_ #f))
|
||
children))))
|
||
|
||
(pass-if "ENOENT"
|
||
(not (file-system-tree "/.does-not-exist."))))
|
||
|
||
(with-test-prefix "scandir"
|
||
|
||
(pass-if "top-srcdir"
|
||
(let ((valid? (negate (cut string-any #\/ <>))))
|
||
(match (scandir %top-srcdir)
|
||
(((? valid? files) ...)
|
||
;; Both subdirs and files must be included.
|
||
(let ((expected '("libguile" "README" "COPYING"
|
||
"test-suite" "Makefile.am"
|
||
"." "..")))
|
||
(lset= string=?
|
||
(lset-intersection string=? files expected)
|
||
expected))))))
|
||
|
||
(pass-if "test-suite"
|
||
(let ((select? (cut string-suffix? ".test" <>)))
|
||
(match (scandir (string-append %test-dir "/tests") select?)
|
||
(("." ".." "00-initial-env.test" (? select?) ...)
|
||
#t))))
|
||
|
||
(pass-if "flat file"
|
||
(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:
|