Commit | Line | Data |
---|---|---|
5e996bd6 KR |
1 | ;;;; filesys.test --- test file system functions -*- scheme -*- |
2 | ;;;; | |
fbac7c61 | 3 | ;;;; Copyright (C) 2004, 2006, 2013 Free Software Foundation, Inc. |
5e996bd6 KR |
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 | |
53befeb7 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
5e996bd6 KR |
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 | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
5e996bd6 KR |
18 | |
19 | (define-module (test-suite test-filesys) | |
6e7d5622 | 20 | #:use-module (test-suite lib) |
fbac7c61 LC |
21 | #:use-module (test-suite guile-test) |
22 | #:use-module (ice-9 match) | |
23 | #:use-module (rnrs io ports) | |
24 | #:use-module (rnrs bytevectors)) | |
6e7d5622 KR |
25 | |
26 | (define (test-file) | |
27 | (data-file-name "filesys-test.tmp")) | |
28 | (define (test-symlink) | |
29 | (data-file-name "filesys-test-link.tmp")) | |
30 | ||
5e996bd6 KR |
31 | |
32 | ;;; | |
33 | ;;; copy-file | |
34 | ;;; | |
35 | ||
36 | (with-test-prefix "copy-file" | |
37 | ||
38 | ;; return next prospective file descriptor number | |
39 | (define (next-fd) | |
40 | (let ((fd (dup 0))) | |
41 | (close fd) | |
42 | fd)) | |
43 | ||
44 | ;; in guile 1.6.4 and earlier, copy-file didn't close the input fd when | |
45 | ;; the output could not be opened | |
46 | (pass-if "fd leak when dest unwritable" | |
47 | (let ((old-next (next-fd))) | |
48 | (false-if-exception (copy-file "/dev/null" "no/such/dir/foo")) | |
49 | (= old-next (next-fd))))) | |
6e7d5622 KR |
50 | |
51 | ;;; | |
52 | ;;; lstat | |
53 | ;;; | |
54 | ||
55 | (with-test-prefix "lstat" | |
56 | ||
57 | (pass-if "normal file" | |
58 | (call-with-output-file (test-file) | |
59 | (lambda (port) | |
60 | (display "hello" port))) | |
61 | (eqv? 5 (stat:size (lstat (test-file))))) | |
62 | ||
63 | (call-with-output-file (test-file) | |
64 | (lambda (port) | |
65 | (display "hello" port))) | |
9560d8bb | 66 | (false-if-exception (delete-file (test-symlink))) |
6e7d5622 KR |
67 | (if (not (false-if-exception |
68 | (begin (symlink (test-file) (test-symlink)) #t))) | |
69 | (display "cannot create symlink, lstat test skipped\n") | |
70 | (pass-if "symlink" | |
71 | ;; not much to test, except that it works | |
72 | (->bool (lstat (test-symlink)))))) | |
73 | ||
74 | ;;; | |
75 | ;;; opendir and friends | |
76 | ;;; | |
77 | ||
78 | (with-test-prefix "opendir" | |
79 | ||
80 | (with-test-prefix "root directory" | |
81 | (let ((d (opendir "/"))) | |
82 | (pass-if "not empty" | |
83 | (string? (readdir d))) | |
84 | (pass-if "all entries are strings" | |
85 | (let more () | |
86 | (let ((f (readdir d))) | |
87 | (cond ((string? f) | |
88 | (more)) | |
89 | ((eof-object? f) | |
90 | #t) | |
91 | (else | |
92 | #f))))) | |
93 | (closedir d)))) | |
94 | ||
95 | ;;; | |
96 | ;;; stat | |
97 | ;;; | |
98 | ||
99 | (with-test-prefix "stat" | |
100 | ||
101 | (with-test-prefix "filename" | |
102 | ||
103 | (pass-if "size" | |
104 | (call-with-output-file (test-file) | |
105 | (lambda (port) | |
106 | (display "hello" port))) | |
107 | (eqv? 5 (stat:size (stat (test-file)))))) | |
108 | ||
109 | (with-test-prefix "file descriptor" | |
110 | ||
111 | (pass-if "size" | |
112 | (call-with-output-file (test-file) | |
113 | (lambda (port) | |
114 | (display "hello" port))) | |
115 | (let* ((fd (open-fdes (test-file) O_RDONLY)) | |
116 | (st (stat fd))) | |
117 | (close-fdes fd) | |
118 | (eqv? 5 (stat:size st))))) | |
119 | ||
120 | (with-test-prefix "port" | |
121 | ||
122 | (pass-if "size" | |
123 | (call-with-output-file (test-file) | |
124 | (lambda (port) | |
125 | (display "hello" port))) | |
126 | (let* ((port (open-file (test-file) "r+")) | |
127 | (st (stat port))) | |
128 | (close-port port) | |
129 | (eqv? 5 (stat:size st)))))) | |
130 | ||
fbac7c61 LC |
131 | (with-test-prefix "sendfile" |
132 | ||
e0886e07 LC |
133 | (let* ((file (search-path %load-path "ice-9/boot-9.scm")) |
134 | (len (stat:size (stat file))) | |
135 | (ref (call-with-input-file file get-bytevector-all))) | |
136 | ||
137 | (pass-if-equal "file" (cons len ref) | |
7f3be1db MW |
138 | (let* ((result (call-with-input-file file |
139 | (lambda (input) | |
140 | (call-with-output-file (test-file) | |
141 | (lambda (output) | |
142 | (sendfile output input len 0)))))) | |
143 | (out (call-with-input-file (test-file) get-bytevector-all))) | |
144 | (cons result out))) | |
e0886e07 LC |
145 | |
146 | (pass-if-equal "file with offset" | |
147 | (cons (- len 777) (call-with-input-file file | |
148 | (lambda (input) | |
149 | (seek input 777 SEEK_SET) | |
150 | (get-bytevector-all input)))) | |
7f3be1db MW |
151 | (let* ((result (call-with-input-file file |
152 | (lambda (input) | |
153 | (call-with-output-file (test-file) | |
154 | (lambda (output) | |
155 | (sendfile output input (- len 777) 777)))))) | |
156 | (out (call-with-input-file (test-file) get-bytevector-all))) | |
157 | (cons result out))) | |
158 | ||
159 | (pass-if-equal "file with offset past the end" | |
160 | (cons (- len 777) (call-with-input-file file | |
161 | (lambda (input) | |
162 | (seek input 777 SEEK_SET) | |
163 | (get-bytevector-all input)))) | |
164 | (let* ((result (call-with-input-file file | |
165 | (lambda (input) | |
166 | (call-with-output-file (test-file) | |
167 | (lambda (output) | |
168 | (sendfile output input len 777)))))) | |
169 | (out (call-with-input-file (test-file) get-bytevector-all))) | |
170 | (cons result out))) | |
171 | ||
172 | (pass-if-equal "file with offset near the end" | |
173 | (cons 77 (call-with-input-file file | |
174 | (lambda (input) | |
175 | (seek input (- len 77) SEEK_SET) | |
176 | (get-bytevector-all input)))) | |
177 | (let* ((result (call-with-input-file file | |
178 | (lambda (input) | |
179 | (call-with-output-file (test-file) | |
180 | (lambda (output) | |
181 | (sendfile output input len (- len 77))))))) | |
182 | (out (call-with-input-file (test-file) get-bytevector-all))) | |
183 | (cons result out))) | |
e0886e07 LC |
184 | |
185 | (pass-if-equal "pipe" (cons len ref) | |
186 | (if (provided? 'threads) | |
187 | (let* ((in+out (pipe)) | |
188 | (child (call-with-new-thread | |
189 | (lambda () | |
190 | (call-with-input-file file | |
191 | (lambda (input) | |
192 | (let ((result (sendfile (cdr in+out) | |
193 | (fileno input) | |
194 | len 0))) | |
195 | (close-port (cdr in+out)) | |
196 | result))))))) | |
197 | (let ((out (get-bytevector-all (car in+out)))) | |
198 | (close-port (car in+out)) | |
199 | (cons (join-thread child) out))) | |
200 | (throw 'unresolved))) | |
201 | ||
202 | (pass-if-equal "pipe with offset" | |
203 | (cons (- len 777) (call-with-input-file file | |
45417ab1 | 204 | (lambda (input) |
e0886e07 LC |
205 | (seek input 777 SEEK_SET) |
206 | (get-bytevector-all input)))) | |
207 | (if (provided? 'threads) | |
208 | (let* ((in+out (pipe)) | |
209 | (child (call-with-new-thread | |
210 | (lambda () | |
211 | (call-with-input-file file | |
212 | (lambda (input) | |
213 | (let ((result (sendfile (cdr in+out) | |
214 | (fileno input) | |
215 | (- len 777) | |
216 | 777))) | |
217 | (close-port (cdr in+out)) | |
218 | result))))))) | |
219 | (let ((out (get-bytevector-all (car in+out)))) | |
220 | (close-port (car in+out)) | |
221 | (cons (join-thread child) out))) | |
222 | (throw 'unresolved))))) | |
fbac7c61 | 223 | |
c56c0f79 | 224 | (delete-file (test-file)) |
9f7914d3 LC |
225 | (when (file-exists? (test-symlink)) |
226 | (delete-file (test-symlink))) |