ftw.test 14 KB

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