X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/a5720988bb39845d7845ace6cea32c5d7f89dfb4..0d96acac33b867f45203e0a0c7b6e87a3a09cdad:/test-suite/tests/ftw.test

diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index c0cbb92cd..7cd88e470 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -1,11 +1,11 @@
 ;;;; 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
@@ -18,7 +18,10 @@
 
 (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
@@ -72,3 +75,267 @@
     (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 %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: