Commit | Line | Data |
---|---|---|
7b041912 | 1 | ;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*- |
7ef450bf | 2 | ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 |
000ee07f | 3 | ;;;; |
7b041912 | 4 | ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010 Free Software Foundation, Inc. |
000ee07f | 5 | ;;;; |
53befeb7 NJ |
6 | ;;;; This library is free software; you can redistribute it and/or |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
000ee07f | 10 | ;;;; |
53befeb7 | 11 | ;;;; This library is distributed in the hope that it will be useful, |
000ee07f | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
000ee07f | 15 | ;;;; |
53befeb7 NJ |
16 | ;;;; You should have received a copy of the GNU Lesser General Public |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
000ee07f | 19 | |
8aa28a91 DH |
20 | (define-module (test-suite test-ports) |
21 | :use-module (test-suite lib) | |
22 | :use-module (test-suite guile-test) | |
23 | :use-module (ice-9 popen) | |
211683cc MG |
24 | :use-module (ice-9 rdelim) |
25 | :use-module (rnrs bytevectors)) | |
000ee07f JB |
26 | |
27 | (define (display-line . args) | |
28 | (for-each display args) | |
29 | (newline)) | |
30 | ||
31 | (define (test-file) | |
c685b42f | 32 | (data-file-name "ports-test.tmp")) |
000ee07f JB |
33 | |
34 | \f | |
35 | ;;;; Some general utilities for testing ports. | |
36 | ||
d6a6989e LC |
37 | ;; Make sure we are set up for 8-bit Latin-1 data. |
38 | (fluid-set! %default-port-encoding "ISO-8859-1") | |
39 | (for-each (lambda (p) | |
40 | (set-port-encoding! p (fluid-ref %default-port-encoding))) | |
41 | (list (current-input-port) (current-output-port) | |
42 | (current-error-port))) | |
889975e5 | 43 | |
000ee07f JB |
44 | ;;; Read from PORT until EOF, and return the result as a string. |
45 | (define (read-all port) | |
46 | (let loop ((chars '())) | |
47 | (let ((char (read-char port))) | |
48 | (if (eof-object? char) | |
49 | (list->string (reverse! chars)) | |
50 | (loop (cons char chars)))))) | |
51 | ||
52 | (define (read-file filename) | |
53 | (let* ((port (open-input-file filename)) | |
54 | (string (read-all port))) | |
55 | (close-port port) | |
56 | string)) | |
57 | ||
58 | \f | |
59 | ;;;; Normal file ports. | |
60 | ||
61 | ;;; Write out an s-expression, and read it back. | |
57e7f270 DH |
62 | (let ((string '("From fairest creatures we desire increase," |
63 | "That thereby beauty's rose might never die,")) | |
64 | (filename (test-file))) | |
65 | (let ((port (open-output-file filename))) | |
66 | (write string port) | |
67 | (close-port port)) | |
68 | (let ((port (open-input-file filename))) | |
69 | (let ((in-string (read port))) | |
70 | (pass-if "file: write and read back list of strings" | |
71 | (equal? string in-string))) | |
72 | (close-port port)) | |
73 | (delete-file filename)) | |
000ee07f JB |
74 | |
75 | ;;; Write out a string, and read it back a character at a time. | |
57e7f270 DH |
76 | (let ((string "This is a test string\nwith no newline at the end") |
77 | (filename (test-file))) | |
78 | (let ((port (open-output-file filename))) | |
79 | (display string port) | |
80 | (close-port port)) | |
81 | (let ((in-string (read-file filename))) | |
82 | (pass-if "file: write and read back characters" | |
83 | (equal? string in-string))) | |
84 | (delete-file filename)) | |
000ee07f | 85 | |
7c035009 | 86 | ;;; Buffered input/output port with seeking. |
57e7f270 DH |
87 | (let* ((filename (test-file)) |
88 | (port (open-file filename "w+"))) | |
89 | (display "J'Accuse" port) | |
90 | (seek port -1 SEEK_CUR) | |
91 | (pass-if "file: r/w 1" | |
92 | (char=? (read-char port) #\e)) | |
93 | (pass-if "file: r/w 2" | |
94 | (eof-object? (read-char port))) | |
95 | (seek port -1 SEEK_CUR) | |
96 | (write-char #\x port) | |
97 | (seek port 7 SEEK_SET) | |
98 | (pass-if "file: r/w 3" | |
99 | (char=? (read-char port) #\x)) | |
100 | (seek port -2 SEEK_END) | |
101 | (pass-if "file: r/w 4" | |
102 | (char=? (read-char port) #\s)) | |
8f99e3f3 | 103 | (close-port port) |
57e7f270 | 104 | (delete-file filename)) |
7c035009 GH |
105 | |
106 | ;;; Unbuffered input/output port with seeking. | |
57e7f270 DH |
107 | (let* ((filename (test-file)) |
108 | (port (open-file filename "w+0"))) | |
109 | (display "J'Accuse" port) | |
110 | (seek port -1 SEEK_CUR) | |
111 | (pass-if "file: ub r/w 1" | |
112 | (char=? (read-char port) #\e)) | |
113 | (pass-if "file: ub r/w 2" | |
114 | (eof-object? (read-char port))) | |
115 | (seek port -1 SEEK_CUR) | |
116 | (write-char #\x port) | |
117 | (seek port 7 SEEK_SET) | |
118 | (pass-if "file: ub r/w 3" | |
119 | (char=? (read-char port) #\x)) | |
120 | (seek port -2 SEEK_END) | |
121 | (pass-if "file: ub r/w 4" | |
122 | (char=? (read-char port) #\s)) | |
8f99e3f3 | 123 | (close-port port) |
57e7f270 | 124 | (delete-file filename)) |
7c035009 | 125 | |
4fcd6551 | 126 | ;;; Buffered output-only and input-only ports with seeking. |
57e7f270 DH |
127 | (let* ((filename (test-file)) |
128 | (port (open-output-file filename))) | |
129 | (display "J'Accuse" port) | |
130 | (pass-if "file: out tell" | |
131 | (= (seek port 0 SEEK_CUR) 8)) | |
132 | (seek port -1 SEEK_CUR) | |
133 | (write-char #\x port) | |
134 | (close-port port) | |
135 | (let ((iport (open-input-file filename))) | |
136 | (pass-if "file: in tell 0" | |
137 | (= (seek iport 0 SEEK_CUR) 0)) | |
138 | (read-char iport) | |
139 | (pass-if "file: in tell 1" | |
140 | (= (seek iport 0 SEEK_CUR) 1)) | |
141 | (unread-char #\z iport) | |
142 | (pass-if "file: in tell 0 after unread" | |
143 | (= (seek iport 0 SEEK_CUR) 0)) | |
144 | (pass-if "file: unread char still there" | |
145 | (char=? (read-char iport) #\z)) | |
146 | (seek iport 7 SEEK_SET) | |
147 | (pass-if "file: in last char" | |
148 | (char=? (read-char iport) #\x)) | |
149 | (close-port iport)) | |
150 | (delete-file filename)) | |
4fcd6551 | 151 | |
7f214e60 | 152 | ;;; unusual characters. |
57e7f270 DH |
153 | (let* ((filename (test-file)) |
154 | (port (open-output-file filename))) | |
155 | (display (string #\nul (integer->char 255) (integer->char 128) | |
156 | #\nul) port) | |
157 | (close-port port) | |
158 | (let* ((port (open-input-file filename)) | |
159 | (line (read-line port))) | |
160 | (pass-if "file: read back NUL 1" | |
161 | (char=? (string-ref line 0) #\nul)) | |
162 | (pass-if "file: read back 255" | |
163 | (char=? (string-ref line 1) (integer->char 255))) | |
164 | (pass-if "file: read back 128" | |
165 | (char=? (string-ref line 2) (integer->char 128))) | |
166 | (pass-if "file: read back NUL 2" | |
167 | (char=? (string-ref line 3) #\nul)) | |
168 | (pass-if "file: EOF" | |
8f99e3f3 SJ |
169 | (eof-object? (read-char port))) |
170 | (close-port port)) | |
57e7f270 | 171 | (delete-file filename)) |
7f214e60 | 172 | |
0eb2e8cd | 173 | ;;; line buffering mode. |
57e7f270 DH |
174 | (let* ((filename (test-file)) |
175 | (port (open-file filename "wl")) | |
176 | (test-string "one line more or less")) | |
177 | (write-line test-string port) | |
178 | (let* ((in-port (open-input-file filename)) | |
179 | (line (read-line in-port))) | |
180 | (close-port in-port) | |
181 | (close-port port) | |
182 | (pass-if "file: line buffering" | |
183 | (string=? line test-string))) | |
184 | (delete-file filename)) | |
0eb2e8cd | 185 | |
e50d921b MG |
186 | ;;; read-line should use the port encoding (not the locale encoding). |
187 | (let ((str "ĉu bone?")) | |
211683cc MG |
188 | (with-locale "C" |
189 | (let* ((filename (test-file)) | |
190 | (port (open-file filename "wl"))) | |
191 | (set-port-encoding! port "UTF-8") | |
192 | (write-line str port) | |
193 | (let ((in-port (open-input-file filename))) | |
194 | (set-port-encoding! in-port "UTF-8") | |
195 | (let ((line (read-line in-port))) | |
196 | (close-port in-port) | |
197 | (close-port port) | |
198 | (pass-if "file: read-line honors port encoding" | |
199 | (string=? line str)))) | |
200 | (delete-file filename)))) | |
201 | ||
202 | ;;; binary mode ignores port encoding | |
203 | (pass-if "file: binary mode ignores port encoding" | |
204 | (with-fluids ((%default-port-encoding "UTF-8")) | |
205 | (let* ((filename (test-file)) | |
206 | (port (open-file filename "w")) | |
207 | (test-string "一二三") | |
208 | (binary-test-string | |
209 | (apply string | |
210 | (map integer->char | |
211 | (uniform-vector->list | |
212 | (string->utf8 test-string)))))) | |
213 | (write-line test-string port) | |
214 | (close-port port) | |
215 | (let* ((in-port (open-file filename "rb")) | |
216 | (line (read-line in-port))) | |
217 | (close-port in-port) | |
218 | (delete-file filename) | |
219 | (string=? line binary-test-string))))) | |
220 | ||
221 | ;;; binary mode ignores file coding declaration | |
222 | (pass-if "file: binary mode ignores file coding declaration" | |
223 | (with-fluids ((%default-port-encoding "UTF-8")) | |
224 | (let* ((filename (test-file)) | |
225 | (port (open-file filename "w")) | |
226 | (test-string "一二三") | |
227 | (binary-test-string | |
228 | (apply string | |
229 | (map integer->char | |
230 | (uniform-vector->list | |
231 | (string->utf8 test-string)))))) | |
232 | (write-line ";; coding: utf-8" port) | |
233 | (write-line test-string port) | |
234 | (close-port port) | |
235 | (let* ((in-port (open-file filename "rb")) | |
236 | (line1 (read-line in-port)) | |
237 | (line2 (read-line in-port))) | |
238 | (close-port in-port) | |
239 | (delete-file filename) | |
240 | (string=? line2 binary-test-string))))) | |
241 | ||
242 | ;; open-file honors file coding declarations | |
243 | (pass-if "file: open-file honors coding declarations" | |
244 | (with-fluids ((%default-port-encoding "UTF-8")) | |
245 | (let* ((filename (test-file)) | |
246 | (port (open-output-file filename)) | |
247 | (test-string "€100")) | |
248 | (set-port-encoding! port "ISO-8859-15") | |
249 | (write-line ";; coding: iso-8859-15" port) | |
250 | (write-line test-string port) | |
251 | (close-port port) | |
252 | (let* ((in-port (open-input-file filename)) | |
253 | (line1 (read-line in-port)) | |
254 | (line2 (read-line in-port))) | |
255 | (close-port in-port) | |
256 | (delete-file filename) | |
257 | (string=? line2 test-string))))) | |
e50d921b | 258 | |
d1b143e9 | 259 | ;;; ungetting characters and strings. |
57e7f270 DH |
260 | (with-input-from-string "walk on the moon\nmoon" |
261 | (lambda () | |
262 | (read-char) | |
263 | (unread-char #\a (current-input-port)) | |
264 | (pass-if "unread-char" | |
265 | (char=? (read-char) #\a)) | |
266 | (read-line) | |
267 | (let ((replacenoid "chicken enchilada")) | |
268 | (unread-char #\newline (current-input-port)) | |
269 | (unread-string replacenoid (current-input-port)) | |
270 | (pass-if "unread-string" | |
271 | (string=? (read-line) replacenoid))) | |
272 | (pass-if "unread residue" | |
273 | (string=? (read-line) "moon")))) | |
d1b143e9 | 274 | |
6e822cce | 275 | ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on |
8cc58ec1 GH |
276 | ;;; the reading end. try to read a byte: should get EAGAIN or |
277 | ;;; EWOULDBLOCK error. | |
57e7f270 DH |
278 | (let* ((p (pipe)) |
279 | (r (car p))) | |
280 | (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) | |
281 | (pass-if "non-blocking-I/O" | |
282 | (catch 'system-error | |
283 | (lambda () (read-char r) #f) | |
284 | (lambda (key . args) | |
285 | (and (eq? key 'system-error) | |
286 | (let ((errno (car (list-ref args 3)))) | |
287 | (or (= errno EAGAIN) | |
288 | (= errno EWOULDBLOCK)))))))) | |
22d35615 | 289 | |
000ee07f | 290 | \f |
6e822cce | 291 | ;;;; Pipe (popen) ports. |
000ee07f JB |
292 | |
293 | ;;; Run a command, and read its output. | |
57e7f270 DH |
294 | (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) |
295 | (in-string (read-all pipe))) | |
296 | (close-pipe pipe) | |
297 | (pass-if "pipe: read" | |
298 | (equal? in-string "Howdy there, partner!\n"))) | |
000ee07f JB |
299 | |
300 | ;;; Run a command, send some output to it, and see if it worked. | |
57e7f270 DH |
301 | (let* ((filename (test-file)) |
302 | (pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) | |
303 | (display "Now Jimmy lives on a mushroom cloud\n" pipe) | |
304 | (display "Mommy, why does everybody have a bomb?\n" pipe) | |
305 | (close-pipe pipe) | |
306 | (let ((in-string (read-file filename))) | |
307 | (pass-if "pipe: write" | |
308 | (equal? in-string "Mommy, why does everybody have a bomb?\n"))) | |
309 | (delete-file filename)) | |
000ee07f JB |
310 | |
311 | \f | |
312 | ;;;; Void ports. These are so trivial we don't test them. | |
313 | ||
314 | \f | |
315 | ;;;; String ports. | |
316 | ||
73cb0a97 JB |
317 | (with-test-prefix "string ports" |
318 | ||
319 | ;; Write text to a string port. | |
57e7f270 DH |
320 | (let* ((string "Howdy there, partner!") |
321 | (in-string (call-with-output-string | |
322 | (lambda (port) | |
323 | (display string port) | |
324 | (newline port))))) | |
325 | (pass-if "display text" | |
326 | (equal? in-string (string-append string "\n")))) | |
000ee07f | 327 | |
73cb0a97 | 328 | ;; Write an s-expression to a string port. |
57e7f270 DH |
329 | (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) |
330 | (in-sexpr | |
331 | (call-with-input-string (call-with-output-string | |
332 | (lambda (port) | |
333 | (write sexpr port))) | |
334 | read))) | |
335 | (pass-if "write/read sexpr" | |
336 | (equal? in-sexpr sexpr))) | |
2d9e5bca GH |
337 | |
338 | ;; seeking and unreading from an input string. | |
57e7f270 DH |
339 | (let ((text "that text didn't look random to me")) |
340 | (call-with-input-string text | |
341 | (lambda (p) | |
342 | (pass-if "input tell 0" | |
343 | (= (seek p 0 SEEK_CUR) 0)) | |
344 | (read-char p) | |
345 | (pass-if "input tell 1" | |
346 | (= (seek p 0 SEEK_CUR) 1)) | |
347 | (unread-char #\x p) | |
348 | (pass-if "input tell back to 0" | |
349 | (= (seek p 0 SEEK_CUR) 0)) | |
350 | (pass-if "input ungetted char" | |
351 | (char=? (read-char p) #\x)) | |
352 | (seek p 0 SEEK_END) | |
353 | (pass-if "input seek to end" | |
354 | (= (seek p 0 SEEK_CUR) | |
355 | (string-length text))) | |
356 | (unread-char #\x p) | |
357 | (pass-if "input seek to beginning" | |
358 | (= (seek p 0 SEEK_SET) 0)) | |
359 | (pass-if "input reread first char" | |
360 | (char=? (read-char p) | |
361 | (string-ref text 0)))))) | |
362 | ||
2d9e5bca | 363 | ;; seeking an output string. |
e4cbd1d8 | 364 | (let* ((text (string-copy "123456789")) |
57e7f270 DH |
365 | (len (string-length text)) |
366 | (result (call-with-output-string | |
367 | (lambda (p) | |
368 | (pass-if "output tell 0" | |
369 | (= (seek p 0 SEEK_CUR) 0)) | |
370 | (display text p) | |
371 | (pass-if "output tell end" | |
372 | (= (seek p 0 SEEK_CUR) len)) | |
373 | (pass-if "output seek to beginning" | |
374 | (= (seek p 0 SEEK_SET) 0)) | |
375 | (write-char #\a p) | |
376 | (seek p -1 SEEK_END) | |
377 | (pass-if "output seek to last char" | |
378 | (= (seek p 0 SEEK_CUR) | |
379 | (- len 1))) | |
380 | (write-char #\b p))))) | |
381 | (string-set! text 0 #\a) | |
382 | (string-set! text (- len 1) #\b) | |
383 | (pass-if "output check" | |
7b041912 LC |
384 | (string=? text result))) |
385 | ||
386 | (pass-if "%default-port-encoding is honored" | |
387 | (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3"))) | |
388 | (equal? (map (lambda (e) | |
389 | (with-fluids ((%default-port-encoding e)) | |
390 | (call-with-output-string | |
391 | (lambda (p) | |
392 | (display (port-encoding p) p))))) | |
393 | encodings) | |
394 | encodings))) | |
395 | ||
396 | (pass-if "suitable encoding [latin-1]" | |
397 | (let ((str "hello, world")) | |
398 | (with-fluids ((%default-port-encoding "ISO-8859-1")) | |
399 | (equal? str | |
400 | (with-output-to-string | |
401 | (lambda () | |
402 | (display str))))))) | |
403 | ||
404 | (pass-if "suitable encoding [latin-3]" | |
405 | (let ((str "ĉu bone?")) | |
406 | (with-fluids ((%default-port-encoding "ISO-8859-3")) | |
407 | (equal? str | |
408 | (with-output-to-string | |
409 | (lambda () | |
410 | (display str))))))) | |
411 | ||
ef7e4ba3 | 412 | (pass-if "wrong encoding" |
7b041912 | 413 | (let ((str "ĉu bone?")) |
ef7e4ba3 LC |
414 | (catch 'encoding-error |
415 | (lambda () | |
416 | ;; Latin-1 cannot represent ‘ĉ’. | |
417 | (with-fluids ((%default-port-encoding "ISO-8859-1")) | |
418 | (with-output-to-string | |
419 | (lambda () | |
420 | (display str))))) | |
421 | (lambda (key subr message errno from to faulty-str) | |
422 | (and (eq? faulty-str str) | |
423 | (string=? from "UTF-32") | |
424 | (string=? to "ISO-8859-1") | |
fd5eec2b LC |
425 | (string? (strerror errno))))))) |
426 | ||
427 | (pass-if "peek-char [latin-1]" | |
428 | (let ((p (with-fluids ((%default-port-encoding #f)) | |
429 | (open-input-string "hello, world")))) | |
430 | (and (char=? (peek-char p) #\h) | |
431 | (char=? (peek-char p) #\h) | |
432 | (char=? (peek-char p) #\h) | |
433 | (= (port-line p) 0) | |
434 | (= (port-column p) 0)))) | |
435 | ||
436 | (pass-if "peek-char [utf-8]" | |
437 | (let ((p (with-fluids ((%default-port-encoding "UTF-8")) | |
438 | (open-input-string "안녕하세요")))) | |
439 | (and (char=? (peek-char p) #\안) | |
440 | (char=? (peek-char p) #\안) | |
441 | (char=? (peek-char p) #\안) | |
442 | (= (port-line p) 0) | |
443 | (= (port-column p) 0))))) | |
2d9e5bca | 444 | |
ee6eedcd KR |
445 | (with-test-prefix "call-with-output-string" |
446 | ||
447 | ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't | |
448 | ;; occur. | |
449 | (pass-if-exception "proc closes port" exception:wrong-type-arg | |
450 | (call-with-output-string close-port))) | |
451 | ||
000ee07f JB |
452 | |
453 | \f | |
454 | ;;;; Soft ports. No tests implemented yet. | |
455 | ||
456 | \f | |
457 | ;;;; Generic operations across all port types. | |
458 | ||
459 | (let ((port-loop-temp (test-file))) | |
460 | ||
461 | ;; Return a list of input ports that all return the same text. | |
462 | ;; We map tests over this list. | |
463 | (define (input-port-list text) | |
464 | ||
465 | ;; Create a text file some of the ports will use. | |
466 | (let ((out-port (open-output-file port-loop-temp))) | |
467 | (display text out-port) | |
468 | (close-port out-port)) | |
469 | ||
470 | (list (open-input-file port-loop-temp) | |
471 | (open-input-pipe (string-append "cat " port-loop-temp)) | |
472 | (call-with-input-string text (lambda (x) x)) | |
473 | ;; We don't test soft ports at the moment. | |
474 | )) | |
475 | ||
476 | (define port-list-names '("file" "pipe" "string")) | |
477 | ||
478 | ;; Test the line counter. | |
73cb0a97 | 479 | (define (test-line-counter text second-line final-column) |
000ee07f JB |
480 | (with-test-prefix "line counter" |
481 | (let ((ports (input-port-list text))) | |
482 | (for-each | |
483 | (lambda (port port-name) | |
484 | (with-test-prefix port-name | |
485 | (pass-if "at beginning of input" | |
486 | (= (port-line port) 0)) | |
487 | (pass-if "read first character" | |
488 | (eqv? (read-char port) #\x)) | |
489 | (pass-if "after reading one character" | |
490 | (= (port-line port) 0)) | |
491 | (pass-if "read first newline" | |
492 | (eqv? (read-char port) #\newline)) | |
493 | (pass-if "after reading first newline char" | |
494 | (= (port-line port) 1)) | |
495 | (pass-if "second line read correctly" | |
496 | (equal? (read-line port) second-line)) | |
497 | (pass-if "read-line increments line number" | |
498 | (= (port-line port) 2)) | |
0b8faa0e JB |
499 | (pass-if "read-line returns EOF" |
500 | (let loop ((i 0)) | |
501 | (cond | |
502 | ((eof-object? (read-line port)) #t) | |
503 | ((> i 20) #f) | |
504 | (else (loop (+ i 1)))))) | |
000ee07f | 505 | (pass-if "line count is 5 at EOF" |
73cb0a97 JB |
506 | (= (port-line port) 5)) |
507 | (pass-if "column is correct at EOF" | |
508 | (= (port-column port) final-column)))) | |
000ee07f JB |
509 | ports port-list-names) |
510 | (for-each close-port ports) | |
511 | (delete-file port-loop-temp)))) | |
512 | ||
57e7f270 DH |
513 | (with-test-prefix "newline" |
514 | (test-line-counter | |
515 | (string-append "x\n" | |
516 | "He who receives an idea from me, receives instruction\n" | |
517 | "himself without lessening mine; as he who lights his\n" | |
518 | "taper at mine, receives light without darkening me.\n" | |
519 | " --- Thomas Jefferson\n") | |
520 | "He who receives an idea from me, receives instruction" | |
521 | 0)) | |
522 | ||
523 | (with-test-prefix "no newline" | |
524 | (test-line-counter | |
525 | (string-append "x\n" | |
526 | "He who receives an idea from me, receives instruction\n" | |
527 | "himself without lessening mine; as he who lights his\n" | |
528 | "taper at mine, receives light without darkening me.\n" | |
529 | " --- Thomas Jefferson\n" | |
530 | "no newline here") | |
531 | "He who receives an idea from me, receives instruction" | |
532 | 15))) | |
5bc1201f | 533 | |
9a8be5a7 MV |
534 | ;; Test port-line and port-column for output ports |
535 | ||
536 | (define (test-output-line-counter text final-column) | |
537 | (with-test-prefix "port-line and port-column for output ports" | |
538 | (let ((port (open-output-string))) | |
539 | (pass-if "at beginning of input" | |
540 | (and (= (port-line port) 0) | |
541 | (= (port-column port) 0))) | |
542 | (write-char #\x port) | |
543 | (pass-if "after writing one character" | |
544 | (and (= (port-line port) 0) | |
545 | (= (port-column port) 1))) | |
546 | (write-char #\newline port) | |
547 | (pass-if "after writing first newline char" | |
548 | (and (= (port-line port) 1) | |
549 | (= (port-column port) 0))) | |
550 | (display text port) | |
551 | (pass-if "line count is 5 at end" | |
552 | (= (port-line port) 5)) | |
553 | (pass-if "column is correct at end" | |
554 | (= (port-column port) final-column))))) | |
555 | ||
556 | (test-output-line-counter | |
557 | (string-append "He who receives an idea from me, receives instruction\n" | |
558 | "himself without lessening mine; as he who lights his\n" | |
559 | "taper at mine, receives light without darkening me.\n" | |
560 | " --- Thomas Jefferson\n" | |
561 | "no newline here") | |
562 | 15) | |
563 | ||
7424deab KR |
564 | (with-test-prefix "port-column" |
565 | ||
566 | (with-test-prefix "output" | |
567 | ||
568 | (pass-if "x" | |
569 | (let ((port (open-output-string))) | |
570 | (display "x" port) | |
571 | (= 1 (port-column port)))) | |
572 | ||
573 | (pass-if "\\a" | |
574 | (let ((port (open-output-string))) | |
575 | (display "\a" port) | |
576 | (= 0 (port-column port)))) | |
577 | ||
578 | (pass-if "x\\a" | |
579 | (let ((port (open-output-string))) | |
580 | (display "x\a" port) | |
581 | (= 1 (port-column port)))) | |
582 | ||
583 | (pass-if "\\x08 backspace" | |
584 | (let ((port (open-output-string))) | |
585 | (display "\x08" port) | |
586 | (= 0 (port-column port)))) | |
587 | ||
588 | (pass-if "x\\x08 backspace" | |
589 | (let ((port (open-output-string))) | |
590 | (display "x\x08" port) | |
591 | (= 0 (port-column port)))) | |
592 | ||
593 | (pass-if "\\n" | |
594 | (let ((port (open-output-string))) | |
595 | (display "\n" port) | |
596 | (= 0 (port-column port)))) | |
597 | ||
598 | (pass-if "x\\n" | |
599 | (let ((port (open-output-string))) | |
600 | (display "x\n" port) | |
601 | (= 0 (port-column port)))) | |
602 | ||
603 | (pass-if "\\r" | |
604 | (let ((port (open-output-string))) | |
605 | (display "\r" port) | |
606 | (= 0 (port-column port)))) | |
607 | ||
608 | (pass-if "x\\r" | |
609 | (let ((port (open-output-string))) | |
610 | (display "x\r" port) | |
611 | (= 0 (port-column port)))) | |
612 | ||
613 | (pass-if "\\t" | |
614 | (let ((port (open-output-string))) | |
615 | (display "\t" port) | |
616 | (= 8 (port-column port)))) | |
617 | ||
618 | (pass-if "x\\t" | |
619 | (let ((port (open-output-string))) | |
620 | (display "x\t" port) | |
621 | (= 8 (port-column port))))) | |
622 | ||
623 | (with-test-prefix "input" | |
624 | ||
625 | (pass-if "x" | |
626 | (let ((port (open-input-string "x"))) | |
627 | (while (not (eof-object? (read-char port)))) | |
628 | (= 1 (port-column port)))) | |
629 | ||
630 | (pass-if "\\a" | |
631 | (let ((port (open-input-string "\a"))) | |
632 | (while (not (eof-object? (read-char port)))) | |
633 | (= 0 (port-column port)))) | |
634 | ||
635 | (pass-if "x\\a" | |
636 | (let ((port (open-input-string "x\a"))) | |
637 | (while (not (eof-object? (read-char port)))) | |
638 | (= 1 (port-column port)))) | |
639 | ||
640 | (pass-if "\\x08 backspace" | |
641 | (let ((port (open-input-string "\x08"))) | |
642 | (while (not (eof-object? (read-char port)))) | |
643 | (= 0 (port-column port)))) | |
644 | ||
645 | (pass-if "x\\x08 backspace" | |
646 | (let ((port (open-input-string "x\x08"))) | |
647 | (while (not (eof-object? (read-char port)))) | |
648 | (= 0 (port-column port)))) | |
649 | ||
650 | (pass-if "\\n" | |
651 | (let ((port (open-input-string "\n"))) | |
652 | (while (not (eof-object? (read-char port)))) | |
653 | (= 0 (port-column port)))) | |
654 | ||
655 | (pass-if "x\\n" | |
656 | (let ((port (open-input-string "x\n"))) | |
657 | (while (not (eof-object? (read-char port)))) | |
658 | (= 0 (port-column port)))) | |
659 | ||
660 | (pass-if "\\r" | |
661 | (let ((port (open-input-string "\r"))) | |
662 | (while (not (eof-object? (read-char port)))) | |
663 | (= 0 (port-column port)))) | |
664 | ||
665 | (pass-if "x\\r" | |
666 | (let ((port (open-input-string "x\r"))) | |
667 | (while (not (eof-object? (read-char port)))) | |
668 | (= 0 (port-column port)))) | |
669 | ||
670 | (pass-if "\\t" | |
671 | (let ((port (open-input-string "\t"))) | |
672 | (while (not (eof-object? (read-char port)))) | |
673 | (= 8 (port-column port)))) | |
674 | ||
675 | (pass-if "x\\t" | |
676 | (let ((port (open-input-string "x\t"))) | |
677 | (while (not (eof-object? (read-char port)))) | |
678 | (= 8 (port-column port)))))) | |
679 | ||
004be623 KR |
680 | (with-test-prefix "port-line" |
681 | ||
682 | ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas | |
683 | ;; scm_t_port actually holds a long; this restricted the range on 64-bit | |
684 | ;; systems | |
685 | (pass-if "set most-positive-fixnum/2" | |
686 | (let ((n (quotient most-positive-fixnum 2)) | |
687 | (port (open-output-string))) | |
688 | (set-port-line! port n) | |
689 | (eqv? n (port-line port))))) | |
690 | ||
256f34e7 KR |
691 | ;;; |
692 | ;;; port-for-each | |
693 | ;;; | |
694 | ||
695 | (with-test-prefix "port-for-each" | |
696 | ||
697 | ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to | |
698 | ;; its iterator func if a port was inaccessible in the last gc mark but | |
699 | ;; the lazy sweeping has not yet reached it to remove it from the port | |
700 | ;; table (scm_i_port_table). Provoking those gc conditions is a little | |
701 | ;; tricky, but the following code made it happen in 1.8.2. | |
702 | (pass-if "passing freed cell" | |
256f34e7 KR |
703 | (let ((lst '())) |
704 | ;; clear out the heap | |
705 | (gc) (gc) (gc) | |
706 | ;; allocate cells so the opened ports aren't at the start of the heap | |
707 | (make-list 1000) | |
708 | (open-input-file "/dev/null") | |
709 | (make-list 1000) | |
710 | (open-input-file "/dev/null") | |
711 | ;; this gc leaves the above ports unmarked, ie. inaccessible | |
712 | (gc) | |
713 | ;; but they're still in the port table, so this sees them | |
714 | (port-for-each (lambda (port) | |
715 | (set! lst (cons port lst)))) | |
716 | ;; this forces completion of the sweeping | |
717 | (gc) (gc) (gc) | |
718 | ;; and (if the bug is present) the cells accumulated in LST are now | |
719 | ;; freed cells, which give #f from `port?' | |
720 | (not (memq #f (map port? lst)))))) | |
721 | ||
e9966dbb HWN |
722 | (with-test-prefix |
723 | "fdes->port" | |
724 | (pass-if "fdes->ports finds port" | |
725 | (let ((port (open-file (test-file) "w"))) | |
726 | ||
727 | (not (not (memq port (fdes->ports (port->fdes port)))))))) | |
728 | ||
8ab3d8a0 KR |
729 | ;;; |
730 | ;;; seek | |
731 | ;;; | |
732 | ||
733 | (with-test-prefix "seek" | |
734 | ||
735 | (with-test-prefix "file port" | |
736 | ||
737 | (pass-if "SEEK_CUR" | |
738 | (call-with-output-file (test-file) | |
739 | (lambda (port) | |
740 | (display "abcde" port))) | |
741 | (let ((port (open-file (test-file) "r"))) | |
742 | (read-char port) | |
743 | (seek port 2 SEEK_CUR) | |
744 | (eqv? #\d (read-char port)))) | |
745 | ||
746 | (pass-if "SEEK_SET" | |
747 | (call-with-output-file (test-file) | |
748 | (lambda (port) | |
749 | (display "abcde" port))) | |
750 | (let ((port (open-file (test-file) "r"))) | |
751 | (read-char port) | |
752 | (seek port 3 SEEK_SET) | |
753 | (eqv? #\d (read-char port)))) | |
754 | ||
755 | (pass-if "SEEK_END" | |
756 | (call-with-output-file (test-file) | |
757 | (lambda (port) | |
758 | (display "abcde" port))) | |
759 | (let ((port (open-file (test-file) "r"))) | |
760 | (read-char port) | |
761 | (seek port -2 SEEK_END) | |
762 | (eqv? #\d (read-char port)))))) | |
763 | ||
6e7d5622 KR |
764 | ;;; |
765 | ;;; truncate-file | |
766 | ;;; | |
767 | ||
768 | (with-test-prefix "truncate-file" | |
769 | ||
8ab3d8a0 KR |
770 | (pass-if-exception "flonum file" exception:wrong-type-arg |
771 | (truncate-file 1.0 123)) | |
772 | ||
773 | (pass-if-exception "frac file" exception:wrong-type-arg | |
774 | (truncate-file 7/3 123)) | |
775 | ||
6e7d5622 KR |
776 | (with-test-prefix "filename" |
777 | ||
8ab3d8a0 KR |
778 | (pass-if-exception "flonum length" exception:wrong-type-arg |
779 | (call-with-output-file (test-file) | |
780 | (lambda (port) | |
781 | (display "hello" port))) | |
782 | (truncate-file (test-file) 1.0)) | |
783 | ||
6e7d5622 KR |
784 | (pass-if "shorten" |
785 | (call-with-output-file (test-file) | |
786 | (lambda (port) | |
787 | (display "hello" port))) | |
788 | (truncate-file (test-file) 1) | |
8ab3d8a0 KR |
789 | (eqv? 1 (stat:size (stat (test-file))))) |
790 | ||
791 | (pass-if-exception "shorten to current pos" exception:miscellaneous-error | |
792 | (call-with-output-file (test-file) | |
793 | (lambda (port) | |
794 | (display "hello" port))) | |
795 | (truncate-file (test-file)))) | |
6e7d5622 KR |
796 | |
797 | (with-test-prefix "file descriptor" | |
798 | ||
799 | (pass-if "shorten" | |
800 | (call-with-output-file (test-file) | |
801 | (lambda (port) | |
802 | (display "hello" port))) | |
803 | (let ((fd (open-fdes (test-file) O_RDWR))) | |
804 | (truncate-file fd 1) | |
805 | (close-fdes fd)) | |
8ab3d8a0 KR |
806 | (eqv? 1 (stat:size (stat (test-file))))) |
807 | ||
808 | (pass-if "shorten to current pos" | |
809 | (call-with-output-file (test-file) | |
810 | (lambda (port) | |
811 | (display "hello" port))) | |
812 | (let ((fd (open-fdes (test-file) O_RDWR))) | |
813 | (seek fd 1 SEEK_SET) | |
814 | (truncate-file fd) | |
815 | (close-fdes fd)) | |
6e7d5622 KR |
816 | (eqv? 1 (stat:size (stat (test-file)))))) |
817 | ||
818 | (with-test-prefix "file port" | |
819 | ||
820 | (pass-if "shorten" | |
821 | (call-with-output-file (test-file) | |
822 | (lambda (port) | |
823 | (display "hello" port))) | |
824 | (let ((port (open-file (test-file) "r+"))) | |
825 | (truncate-file port 1)) | |
8ab3d8a0 KR |
826 | (eqv? 1 (stat:size (stat (test-file))))) |
827 | ||
828 | (pass-if "shorten to current pos" | |
829 | (call-with-output-file (test-file) | |
830 | (lambda (port) | |
831 | (display "hello" port))) | |
832 | (let ((port (open-file (test-file) "r+"))) | |
833 | (read-char port) | |
834 | (truncate-file port)) | |
6e7d5622 KR |
835 | (eqv? 1 (stat:size (stat (test-file))))))) |
836 | ||
7424deab | 837 | |
5bc1201f JB |
838 | ;;;; testing read-delimited and friends |
839 | ||
840 | (with-test-prefix "read-delimited!" | |
841 | (let ((c (make-string 20 #\!))) | |
842 | (call-with-input-string | |
843 | "defdef\nghighi\n" | |
844 | (lambda (port) | |
845 | ||
846 | (read-delimited! "\n" c port 'concat) | |
847 | (pass-if "read-delimited! reads a first line" | |
848 | (string=? c "defdef\n!!!!!!!!!!!!!")) | |
849 | ||
850 | (read-delimited! "\n" c port 'concat 3) | |
851 | (pass-if "read-delimited! reads a first line" | |
852 | (string=? c "defghighi\n!!!!!!!!!!")))))) | |
1b054952 JB |
853 | |
854 | \f | |
855 | ;;;; char-ready? | |
856 | ||
857 | (call-with-input-string | |
858 | "howdy" | |
859 | (lambda (port) | |
860 | (pass-if "char-ready? returns true on string port" | |
861 | (char-ready? port)))) | |
862 | ||
863 | ;;; This segfaults on some versions of Guile. We really should run | |
864 | ;;; the tests in a subprocess... | |
865 | ||
866 | (call-with-input-string | |
867 | "howdy" | |
868 | (lambda (port) | |
869 | (with-input-from-port | |
870 | port | |
871 | (lambda () | |
872 | (pass-if "char-ready? returns true on string port as default port" | |
873 | (char-ready?)))))) | |
fe5b6beb JB |
874 | |
875 | \f | |
876 | ;;;; Close current-input-port, and make sure everyone can handle it. | |
877 | ||
878 | (with-test-prefix "closing current-input-port" | |
879 | (for-each (lambda (procedure name) | |
880 | (with-input-from-port | |
881 | (call-with-input-string "foo" (lambda (p) p)) | |
882 | (lambda () | |
883 | (close-port (current-input-port)) | |
6b4113af DH |
884 | (pass-if-exception name |
885 | exception:wrong-type-arg | |
886 | (procedure))))) | |
fe5b6beb JB |
887 | (list read read-char read-line) |
888 | '("read" "read-char" "read-line"))) | |
c56c0f79 MV |
889 | |
890 | (delete-file (test-file)) |