test-suite/tests/ftw.test

   1 ;;;; ftw.test --- exercise ice-9/ftw.scm      -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2006, 2011, 2012 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-ice-9-ftw)
  20   #:use-module (test-suite lib)
  21   #:use-module (ice-9 ftw)
  22   #:use-module (ice-9 match)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-26))
  25
  26
  27 ;; the procedure-source checks here ensure the vector indexes we write match
  28 ;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match
  29 ;; libguile/filesys.c of course)
  30
  31 (define (stat:dev! st dev)
  32   (vector-set! st 0 dev))
  33 (define (stat:ino! st ino)
  34   (vector-set! st 1 ino))
  35
  36 (let* ((s (stat "/"))
  37        (i (stat:ino s))
  38        (d (stat:dev s)))
  39   (stat:ino! s (1+ i))
  40   (stat:dev! s (1+ d))
  41   (if (not (and (= (stat:ino s) (1+ i))
  42                 (= (stat:dev s) (1+ d))))
  43       (error "unexpected definitions of stat:dev and stat:ino")))
  44
  45 ;;
  46 ;; visited?-proc
  47 ;;
  48
  49 (with-test-prefix "visited?-proc"
  50
  51   ;; normally internal-only
  52   (let* ((visited?-proc (@@ (ice-9 ftw) visited?-proc))
  53          (visited? (visited?-proc 97))
  54          (s (stat "/")))
  55
  56     (define (try-visited? dev ino)
  57       (stat:dev! s dev)
  58       (stat:ino! s ino)
  59       (visited? s))
  60
  61     (pass-if "0 0 - 1st" (eq? #f (try-visited? 0 0)))
  62     (pass-if "0 0 - 2nd" (eq? #t (try-visited? 0 0)))
  63     (pass-if "0 0 - 3rd" (eq? #t (try-visited? 0 0)))
  64
  65     (pass-if "0 1" (eq? #f (try-visited? 0 1)))
  66     (pass-if "0 2" (eq? #f (try-visited? 0 2)))
  67     (pass-if "0 3" (eq? #f (try-visited? 0 3)))
  68
  69     (pass-if "5 5" (eq? #f (try-visited? 5 5)))
  70     (pass-if "5 7" (eq? #f (try-visited? 5 7)))
  71     (pass-if "7 5" (eq? #f (try-visited? 7 5)))
  72     (pass-if "7 7" (eq? #f (try-visited? 7 7)))
  73
  74     (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5)))
  75     (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7)))
  76     (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5)))
  77     (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7)))))
  78
  79 \f
  80 ;;;
  81 ;;; `file-system-fold' & co.
  82 ;;;
  83
  84 (define %top-builddir
  85   (canonicalize-path (getcwd)))
  86
  87 (define %top-srcdir
  88   (assq-ref %guile-build-info 'top_srcdir))
  89
  90 (define %test-dir
  91   (string-append %top-srcdir "/test-suite"))
  92
  93 (define %test-suite-lib-dir
  94   (string-append %top-srcdir "/test-suite/test-suite"))
  95
  96 (define (make-file-tree dir tree)
  97   "Make file system TREE at DIR."
  98   (define (touch file)
  99     (call-with-output-file file
 100       (cut display "" <>)))
 101
 102   (let loop ((dir  dir)
 103              (tree tree))
 104     (define (scope file)
 105       (string-append dir "/" file))
 106
 107     (match tree
 108       (('directory name (body ...))
 109        (mkdir (scope name))
 110        (for-each (cute loop (scope name) <>) body))
 111       (('directory name (? integer? mode) (body ...))
 112        (mkdir (scope name))
 113        (for-each (cute loop (scope name) <>) body)
 114        (chmod (scope name) mode))
 115       ((file)
 116        (touch (scope file)))
 117       ((file (? integer? mode))
 118        (touch (scope file))
 119        (chmod (scope file) mode))
 120       ((from '-> to)
 121        (symlink to (scope from))))))
 122
 123 (define (delete-file-tree dir tree)
 124   "Delete file TREE from DIR."
 125   (let loop ((dir  dir)
 126              (tree tree))
 127     (define (scope file)
 128       (string-append dir "/" file))
 129
 130     (match tree
 131       (('directory name (body ...))
 132        (for-each (cute loop (scope name) <>) body)
 133        (rmdir (scope name)))
 134       (('directory name (? integer? mode) (body ...))
 135        (chmod (scope name) #o755)          ; make sure it can be entered
 136        (for-each (cute loop (scope name) <>) body)
 137        (rmdir (scope name)))
 138       ((from '-> _)
 139        (delete-file (scope from)))
 140       ((file _ ...)
 141        (delete-file (scope file))))))
 142
 143 (define-syntax-rule (with-file-tree dir tree body ...)
 144   (dynamic-wind
 145     (lambda ()
 146       (make-file-tree dir tree))
 147     (lambda ()
 148       body ...)
 149     (lambda ()
 150       (delete-file-tree dir tree))))
 151
 152 (with-test-prefix "file-system-fold"
 153
 154   (pass-if "test-suite"
 155     (let ((enter? (lambda (n s r)
 156                     ;; Enter only `test-suite/tests/'.
 157                     (if (member `(down ,%test-dir) r)
 158                         (or (string=? (basename n) "tests")
 159                             (string=? (basename n) "test-suite"))
 160                         (string=? (basename n) "test-suite"))))
 161           (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
 162           (down   (lambda (n s r) (cons `(down ,n) r)))
 163           (up     (lambda (n s r) (cons `(up ,n) r)))
 164           (skip   (lambda (n s r) (cons `(skip ,n) r)))
 165           (error  (lambda (n s e r) (cons `(error ,n) r))))
 166       (define seq
 167         (reverse
 168          (file-system-fold enter? leaf down up skip error '() %test-dir)))
 169
 170       (match seq
 171         ((('down (? (cut string=? <> %test-dir)))
 172           between ...
 173           ('up (? (cut string=? <> %test-dir))))
 174          (and (any (match-lambda (('down (= basename "test-suite")) #t) (_ #f))
 175                    between)
 176               (any (match-lambda (('down (= basename "tests")) #t) (_ #f))
 177                    between)
 178               (any (match-lambda (('leaf (= basename "alist.test")) #t) (_ #f))
 179                    between)
 180               (any (match-lambda (('up   (= basename "tests")) #t) (_ #f))
 181                    between)
 182               (any (match-lambda (('skip (= basename "vm")) #t) (_ #f))
 183                    between))))))
 184
 185   (pass-if-equal "test-suite (never enter)"
 186       `((skip ,%test-dir))
 187     (let ((enter? (lambda (n s r) #f))
 188           (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
 189           (down   (lambda (n s r) (cons `(down ,n) r)))
 190           (up     (lambda (n s r) (cons `(up ,n) r)))
 191           (skip   (lambda (n s r) (cons `(skip ,n) r)))
 192           (error  (lambda (n s e r) (cons `(error ,n) r))))
 193       (file-system-fold enter? leaf down up skip error '() %test-dir)))
 194
 195   (let ((name   (string-append %test-suite-lib-dir "/lib.scm")))
 196     (pass-if-equal "test-suite/lib.scm (flat file)"
 197         `((leaf ,name))
 198       (let ((enter? (lambda (n s r) #t))
 199             (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
 200             (down   (lambda (n s r) (cons `(down ,n) r)))
 201             (up     (lambda (n s r) (cons `(up ,n) r)))
 202             (skip   (lambda (n s r) (cons `(skip ,n) r)))
 203             (error  (lambda (n s e r) (cons `(error ,n) r))))
 204         (file-system-fold enter? leaf down up skip error '() name))))
 205
 206   (pass-if "ENOENT"
 207     (let ((enter? (lambda (n s r) #t))
 208           (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
 209           (down   (lambda (n s r) (cons `(down ,n) r)))
 210           (up     (lambda (n s r) (cons `(up ,n) r)))
 211           (skip   (lambda (n s r) (cons `(skip ,n) r)))
 212           (error  (lambda (n s e r) (cons `(error ,n ,e) r)))
 213           (name   "/.does-not-exist."))
 214       (equal? (file-system-fold enter? leaf down up skip error '() name)
 215               `((error ,name ,ENOENT)))))
 216
 217   (let ((name (string-append %top-builddir "/test-EACCES")))
 218     (pass-if-equal "EACCES"
 219         `((error ,name ,EACCES))
 220       (if (zero? (getuid))
 221           ;; When run as root, this test would fail because root can
 222           ;; list the contents of #o000 directories.
 223           (throw 'unresolved)
 224           (with-file-tree %top-builddir '(directory "test-EACCES" #o000
 225                                                     (("a") ("b")))
 226             (let ((enter? (lambda (n s r) #t))
 227                   (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
 228                   (down   (lambda (n s r) (cons `(down ,n) r)))
 229                   (up     (lambda (n s r) (cons `(up ,n) r)))
 230                   (skip   (lambda (n s r) (cons `(skip ,n) r)))
 231                   (error  (lambda (n s e r) (cons `(error ,n ,e) r))))
 232               (file-system-fold enter? leaf down up skip error '() name))))))
 233
 234   (pass-if "dangling symlink and lstat"
 235     (with-file-tree %top-builddir '(directory "test-dangling"
 236                                               (("dangling" -> "xxx")))
 237       (let ((enter? (lambda (n s r) #t))
 238             (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
 239             (down   (lambda (n s r) (cons `(down ,n) r)))
 240             (up     (lambda (n s r) (cons `(up ,n) r)))
 241             (skip   (lambda (n s r) (cons `(skip ,n) r)))
 242             (error  (lambda (n s e r) (cons `(error ,n ,e) r)))
 243             (name   (string-append %top-builddir "/test-dangling")))
 244         (equal? (file-system-fold enter? leaf down up skip error '()
 245                                   name)
 246                 `((up   ,name)
 247                   (leaf ,(string-append name "/dangling"))
 248                   (down ,name))))))
 249
 250   (pass-if "dangling symlink and stat"
 251     ;; Same as above, but using `stat' instead of `lstat'.
 252     (with-file-tree %top-builddir '(directory "test-dangling"
 253                                               (("dangling" -> "xxx")))
 254       (let ((enter? (lambda (n s r) #t))
 255             (leaf   (lambda (n s r) (cons `(leaf ,n) r)))
 256             (down   (lambda (n s r) (cons `(down ,n) r)))
 257             (up     (lambda (n s r) (cons `(up ,n) r)))
 258             (skip   (lambda (n s r) (cons `(skip ,n) r)))
 259             (error  (lambda (n s e r) (cons `(error ,n ,e) r)))
 260             (name   (string-append %top-builddir "/test-dangling")))
 261         (equal? (file-system-fold enter? leaf down up skip error '()
 262                                   name stat)
 263                 `((up    ,name)
 264                   (error ,(string-append name "/dangling") ,ENOENT)
 265                   (down  ,name)))))))
 266
 267 (with-test-prefix "file-system-tree"
 268
 269   (pass-if "test-suite (never enter)"
 270     (match (file-system-tree %test-dir (lambda (n s) #f))
 271       (("test-suite" (= stat:type 'directory))    ; no children
 272        #t)))
 273
 274   (pass-if "test-suite/*"
 275     (match (file-system-tree %test-dir (lambda (n s)
 276                                          (string=? n %test-dir)))
 277       (("test-suite" (= stat:type 'directory) children ...)
 278        (any (match-lambda
 279              (("tests" (= stat:type 'directory))  ; no children
 280               #t)
 281              (_ #f))
 282             children))))
 283
 284   (pass-if "test-suite (recursive)"
 285     (match (file-system-tree %test-dir)
 286       (("test-suite" (= stat:type 'directory) children ...)
 287        (any (match-lambda
 288              (("tests" (= stat:type 'directory) (= car files) ...)
 289               (let ((expected '("alist.test" "bytevectors.test"
 290                                 "ftw.test" "gc.test" "vlist.test")))
 291                 (lset= string=?
 292                        (lset-intersection string=? files expected)
 293                        expected)))
 294              (_ #f))
 295             children))))
 296
 297   (pass-if "ENOENT"
 298     (not (file-system-tree "/.does-not-exist."))))
 299
 300 (with-test-prefix "scandir"
 301
 302   (pass-if "top-srcdir"
 303     (let ((valid? (negate (cut string-any #\/ <>))))
 304       (match (scandir %top-srcdir)
 305         (((? valid? files) ...)
 306          ;; Both subdirs and files must be included.
 307          (let ((expected '("libguile" "README" "COPYING"
 308                            "test-suite" "Makefile.am"
 309                            "." "..")))
 310            (lset= string=?
 311                   (lset-intersection string=? files expected)
 312                   expected))))))
 313
 314   (pass-if "test-suite"
 315     (let ((select? (cut string-suffix? ".test" <>)))
 316       (match (scandir (string-append %test-dir "/tests") select?)
 317         (("00-initial-env.test" (? select?) ...)
 318          #t))))
 319
 320   (pass-if "flat file"
 321     (not (scandir (string-append %test-dir "/Makefile.am"))))
 322
 323   (pass-if "EACCES"
 324     (not (scandir "/.does-not-exist.")))
 325
 326   (pass-if "no select"
 327     (null? (scandir %test-dir (lambda (_) #f))))
 328
 329   ;; In Guile up to 2.0.6, this would return ("." ".." "link-to-dir").
 330   (pass-if-equal "symlink to directory"
 331       '("." ".." "link-to-dir" "subdir")
 332     (with-file-tree %top-builddir '(directory "test-scandir-symlink"
 333                                               (("link-to-dir" -> "subdir")
 334                                                (directory "subdir"
 335                                                           (("a")))))
 336       (let ((name (string-append %top-builddir "/test-scandir-symlink")))
 337         (scandir name)))))
 338
 339 ;;; Local Variables:
 340 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
 341 ;;; End: