;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*-
;;;;
-;;;; Copyright 2006 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
;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; 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
(define-module (test-suite test-ice-9-ftw)
#:use-module (test-suite lib)
- #:use-module (ice-9 ftw))
+ #: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
(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)))))
+
+\f
+;;;
+;;; `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 %test-suite-lib-dir
+ (string-append %top-srcdir "/test-suite/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)
+ (or (string=? (basename n) "tests")
+ (string=? (basename n) "test-suite"))
+ (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 (('down (= basename "test-suite")) #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-equal "test-suite (never enter)"
+ `((skip ,%test-dir))
+ (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))))
+ (file-system-fold enter? leaf down up skip error '() %test-dir)))
+
+ (let ((name (string-append %test-suite-lib-dir "/lib.scm")))
+ (pass-if-equal "test-suite/lib.scm (flat file)"
+ `((leaf ,name))
+ (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))))
+ (file-system-fold enter? leaf down up skip error '() 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)))))
+
+ (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"
+ (("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.")))
+
+ (pass-if "no select"
+ (null? (scandir %test-dir (lambda (_) #f))))
+
+ ;; In Guile up to 2.0.6, this would return ("." ".." "link-to-dir").
+ (pass-if-equal "symlink to directory"
+ '("." ".." "link-to-dir" "subdir")
+ (with-file-tree %top-builddir '(directory "test-scandir-symlink"
+ (("link-to-dir" -> "subdir")
+ (directory "subdir"
+ (("a")))))
+ (let ((name (string-append %top-builddir "/test-scandir-symlink")))
+ (scandir name)))))
+
+;;; Local Variables:
+;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
+;;; End:
HCoop / bpt / guile.git / blobdiff