mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-06 04:00:26 +02:00
a2c66014cf
* module/ice-9/ftw.scm (scandir)[skip]: Keep NAME in the resulting list.
* test-suite/tests/ftw.test ("scandir")["top-srcdir"]: New test.
191 lines
6.8 KiB
Scheme
191 lines
6.8 KiB
Scheme
;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*-
|
||
;;;;
|
||
;;;; Copyright 2006, 2011 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-srcdir
|
||
(assq-ref %guile-build-info 'top_srcdir))
|
||
|
||
(define %test-dir
|
||
(string-append %top-srcdir "/test-suite"))
|
||
|
||
(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))))
|
||
(define seq
|
||
(reverse
|
||
(file-system-fold enter? leaf down up skip '() %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))))
|
||
(equal? (file-system-fold enter? leaf down up skip '() %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)))
|
||
(name (string-append %test-dir "/lib.scm")))
|
||
(equal? (file-system-fold enter? leaf down up skip '() name)
|
||
`((leaf ,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)))))
|
||
|
||
(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")))))
|