1;;;; r6rs-ports.test --- R6RS I/O port tests.   -*- coding: utf-8; -*-
2;;;;
3;;;; Copyright (C) 2009-2012, 2013-2015, 2018 Free Software Foundation, Inc.
4;;;; Ludovic Courtès
5;;;;
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.
10;;;;
11;;;; This library is distributed in the hope that it will be useful,
12;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;;;; Lesser General Public License for more details.
15;;;;
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
19
20(define-module (test-io-ports)
21  #:use-module (test-suite lib)
22  #:use-module (test-suite guile-test)
23  #:use-module (srfi srfi-1)
24  #:use-module (srfi srfi-11)
25  #:use-module (ice-9 match)
26  #:use-module ((ice-9 binary-ports) #:select (get-bytevector-some!))
27  #:use-module (rnrs io ports)
28  #:use-module (rnrs io simple)
29  #:use-module (rnrs exceptions)
30  #:use-module (rnrs bytevectors))
31
32(define-syntax pass-if-condition
33  (syntax-rules ()
34    ((_ name predicate body0 body ...)
35     (let ((cookie (list 'cookie)))
36       (pass-if name
37         (eq? cookie (guard (c ((predicate c) cookie))
38                       body0 body ...)))))))
39
40(define (test-file)
41  (data-file-name "ports-test.tmp"))
42
43;; A input/output port that swallows all output, and produces just
44;; spaces on input.  Reading and writing beyond `failure-position'
45;; produces `system-error' exceptions.  Used for testing exception
46;; behavior.
47(define* (make-failing-port #:optional (failure-position 0))
48  (define (maybe-fail index errno)
49    (if (> index failure-position)
50        (scm-error 'system-error
51                   'failing-port
52                   "I/O beyond failure position" '()
53                   (list errno))))
54  (let ((read-index  0)
55        (write-index 0))
56    (define (write-char chr)
57      (set! write-index (+ 1 write-index))
58      (maybe-fail write-index ENOSPC))
59    (make-soft-port
60     (vector write-char
61             (lambda (str)   ;; write-string
62               (for-each write-char (string->list str)))
63             (lambda () #t)  ;; flush-output
64             (lambda ()      ;; read-char
65               (set! read-index (+ read-index 1))
66               (maybe-fail read-index EIO)
67               #\space)
68             (lambda () #t)) ;; close-port
69     "rw")))
70
71(define (call-with-bytevector-output-port/transcoded transcoder receiver)
72  (call-with-bytevector-output-port
73    (lambda (bv-port)
74      (call-with-port (transcoded-port bv-port transcoder)
75        receiver))))
76
77
78(with-test-prefix "8.2.5 End-of-File Object"
79
80  (pass-if "eof-object"
81    (and (eqv? (eof-object) (eof-object))
82         (eq?  (eof-object) (eof-object))))
83
84  (pass-if "port-eof?"
85    (port-eof? (open-input-string ""))))
86
87
88(with-test-prefix "8.2.8 Binary Input"
89
90  (pass-if "get-u8"
91    (let ((port (open-input-string "A")))
92      (and (= (char->integer #\A) (get-u8 port))
93           (eof-object? (get-u8 port)))))
94
95  (pass-if "lookahead-u8"
96    (let ((port (open-input-string "A")))
97      (and (= (char->integer #\A) (lookahead-u8 port))
98           (= (char->integer #\A) (lookahead-u8 port))
99           (= (char->integer #\A) (get-u8 port))
100           (eof-object? (get-u8 port)))))
101
102  (pass-if "lookahead-u8 non-ASCII"
103    (let ((port (open-input-string "λ")))
104      (and (= 206 (lookahead-u8 port))
105           (= 206 (lookahead-u8 port))
106           (= 206 (get-u8 port))
107           (= 187 (lookahead-u8 port))
108           (= 187 (lookahead-u8 port))
109           (= 187 (get-u8 port))
110           (eof-object? (lookahead-u8 port))
111           (eof-object? (get-u8 port)))))
112
113  (pass-if "lookahead-u8: result is unsigned"
114    ;; Bug #31081.
115    (let ((port (open-bytevector-input-port #vu8(255))))
116      (= (lookahead-u8 port) 255)))
117
118  (pass-if "get-bytevector-n [short]"
119    (let* ((port (open-input-string "GNU Guile"))
120           (bv (get-bytevector-n port 4)))
121      (and (bytevector? bv)
122           (equal? (bytevector->u8-list bv)
123                   (map char->integer (string->list "GNU "))))))
124
125  (pass-if "get-bytevector-n [long]"
126    (let* ((port (open-input-string "GNU Guile"))
127           (bv (get-bytevector-n port 256)))
128      (and (bytevector? bv)
129           (equal? (bytevector->u8-list bv)
130                   (map char->integer (string->list "GNU Guile"))))))
131
132  (pass-if-exception "get-bytevector-n with closed port"
133    exception:wrong-type-arg
134
135    (let ((port (%make-void-port "r")))
136
137      (close-port port)
138      (get-bytevector-n port 3)))
139
140  (let ((expected (make-bytevector 20 (char->integer #\a))))
141    (pass-if-equal "http://bugs.gnu.org/17466"
142        ;; <http://bugs.gnu.org/17466> is about a memory corruption
143        ;; whereas bytevector shrunk in 'get-bytevector-n' would keep
144        ;; referring to the previous (larger) bytevector.
145        expected
146      (let loop ((count 50))
147        (if (zero? count)
148            expected
149            (let ((bv (call-with-input-string "aaaaaaaaaaaaaaaaaaaa"
150                        (lambda (port)
151                          (get-bytevector-n port 4096)))))
152              ;; Cause the 4 KiB bytevector initially created by
153              ;; 'get-bytevector-n' to be reclaimed.
154              (make-bytevector 4096)
155
156              (if (equal? bv expected)
157                  (loop (- count 1))
158                  bv))))))
159
160  (pass-if "get-bytevector-n! [short]"
161    (let* ((port (open-input-string "GNU Guile"))
162           (bv   (make-bytevector 4))
163           (read (get-bytevector-n! port bv 0 4)))
164      (and (equal? read 4)
165           (equal? (bytevector->u8-list bv)
166                   (map char->integer (string->list "GNU "))))))
167
168  (pass-if "get-bytevector-n! [long]"
169    (let* ((str  "GNU Guile")
170           (port (open-input-string str))
171           (bv   (make-bytevector 256))
172           (read (get-bytevector-n! port bv 0 256)))
173      (and (equal? read (string-length str))
174           (equal? (map (lambda (i)
175                          (bytevector-u8-ref bv i))
176                        (iota read))
177                   (map char->integer (string->list str))))))
178
179  (pass-if "get-bytevector-some [simple]"
180    (let* ((str  "GNU Guile")
181           (port (open-input-string str))
182           (bv   (get-bytevector-some port)))
183      (and (bytevector? bv)
184           (equal? (bytevector->u8-list bv)
185                   (map char->integer (string->list str))))))
186
187  (pass-if "get-bytevector-some! [short]"
188    (let* ((port (open-input-string "GNU Guile"))
189           (bv   (make-bytevector 4))
190           (read (get-bytevector-some! port bv 0 4)))
191      (and (equal? read 4)
192           (equal? (bytevector->u8-list bv)
193                   (map char->integer (string->list "GNU "))))))
194
195  (pass-if "get-bytevector-some! [long]"
196    (let* ((str  "GNU Guile")
197           (port (open-input-string str))
198           (bv   (make-bytevector 256))
199           (read (get-bytevector-some! port bv 0 256)))
200      (and (equal? read (string-length str))
201           (equal? (map (lambda (i)
202                          (bytevector-u8-ref bv i))
203                        (iota read))
204                   (map char->integer (string->list str))))))
205
206  (pass-if "get-bytevector-all"
207    (let* ((str   "GNU Guile")
208           (index 0)
209           (port  (make-soft-port
210                   (vector #f #f #f
211                           (lambda ()
212                             (if (>= index (string-length str))
213                                 (eof-object)
214                                 (let ((c (string-ref str index)))
215                                   (set! index (+ index 1))
216                                   c)))
217                           (lambda () #t)
218                           (let ((cont? #f))
219                             (lambda ()
220                               ;; Number of readily available octets: falls to
221                               ;; zero after 4 octets have been read and then
222                               ;; starts again.
223                               (let ((a (if cont?
224                                            (- (string-length str) index)
225                                            (- 4 (modulo index 5)))))
226                                 (if (= 0 a) (set! cont? #t))
227                                 a))))
228                   "r"))
229           (bv    (get-bytevector-all port)))
230      (and (bytevector? bv)
231           (= index (string-length str))
232           (= (bytevector-length bv) (string-length str))
233           (equal? (bytevector->u8-list bv)
234                   (map char->integer (string->list str)))))))
235
236
237(define (make-soft-output-port)
238  (let* ((bv (make-bytevector 1024))
239         (read-index  0)
240         (write-index 0)
241         (write-char (lambda (chr)
242                       (bytevector-u8-set! bv write-index
243                                           (char->integer chr))
244                       (set! write-index (+ 1 write-index)))))
245    (make-soft-port
246     (vector write-char
247             (lambda (str)   ;; write-string
248               (for-each write-char (string->list str)))
249             (lambda () #t)  ;; flush-output
250             (lambda ()      ;; read-char
251               (if (>= read-index (bytevector-length bv))
252                   (eof-object)
253                   (let ((c (bytevector-u8-ref bv read-index)))
254                     (set! read-index (+ read-index 1))
255                     (integer->char c))))
256             (lambda () #t)) ;; close-port
257     "rw")))
258
259(with-test-prefix "8.2.11 Binary Output"
260
261  (pass-if "put-u8"
262    (let ((port (make-soft-output-port)))
263      (put-u8 port 77)
264      (equal? (get-u8 port) 77)))
265
266  ;; Note: The `put-bytevector' tests below temporarily set the default
267  ;; port encoding to ISO-8859-1 so that the soft-port will let all the
268  ;; bytes through, unmodified.  This is hacky, but we can't use "custom
269  ;; binary output ports" here because they're only tested later.
270
271  (pass-if "put-bytevector [2 args]"
272    (with-fluids ((%default-port-encoding "ISO-8859-1"))
273     (let ((port (make-soft-output-port))
274           (bv   (make-bytevector 256)))
275       (put-bytevector port bv)
276       (equal? (bytevector->u8-list bv)
277               (bytevector->u8-list
278                (get-bytevector-n port (bytevector-length bv)))))))
279
280  (pass-if "put-bytevector [3 args]"
281    (with-fluids ((%default-port-encoding "ISO-8859-1"))
282     (let ((port  (make-soft-output-port))
283           (bv    (make-bytevector 256))
284           (start 10))
285       (put-bytevector port bv start)
286       (equal? (drop (bytevector->u8-list bv) start)
287               (bytevector->u8-list
288                (get-bytevector-n port (- (bytevector-length bv) start)))))))
289
290  (pass-if "put-bytevector [4 args]"
291    (with-fluids ((%default-port-encoding "ISO-8859-1"))
292     (let ((port  (make-soft-output-port))
293           (bv    (make-bytevector 256))
294           (start 10)
295           (count 77))
296       (put-bytevector port bv start count)
297       (equal? (take (drop (bytevector->u8-list bv) start) count)
298               (bytevector->u8-list
299                (get-bytevector-n port count))))))
300
301  (pass-if-exception "put-bytevector with closed port"
302    exception:wrong-type-arg
303
304    (let* ((bv   (make-bytevector 4))
305           (port (%make-void-port "w")))
306
307      (close-port port)
308      (put-bytevector port bv)))
309
310  (pass-if "put-bytevector with UTF-16 string port"
311    (let* ((str "hello, world")
312           (bv  (string->utf16 str)))
313      (equal? str
314              (call-with-output-string
315               (lambda (port)
316                 (set-port-encoding! port "UTF-16BE")
317                 (put-bytevector port bv))))))
318
319  (pass-if "put-bytevector with wrong-encoding string port"
320    (let* ((str "hello, world")
321           (bv  (string->utf16 str)))
322      (catch 'decoding-error
323        (lambda ()
324          (with-fluids ((%default-port-conversion-strategy 'error))
325            (call-with-output-string
326             (lambda (port)
327               (set-port-encoding! port "UTF-32")
328               (put-bytevector port bv)))
329            #f))                           ; fail if we reach this point
330        (lambda (key subr message errno port)
331          (string? (strerror errno)))))))
332
333
334(define (test-input-file-opener open filename)
335  (let ((contents (string->utf8 "GNU λ")))
336    ;; Create file
337    (call-with-output-file filename
338      (lambda (port) (put-bytevector port contents)))
339
340    (pass-if "opens binary input port with correct contents"
341      (with-fluids ((%default-port-encoding "UTF-8"))
342        (call-with-port (open-file-input-port filename)
343          (lambda (port)
344            (and (binary-port? port)
345                 (input-port? port)
346                 (bytevector=? contents (get-bytevector-all port))))))))
347
348  (delete-file filename))
349
350(with-test-prefix "8.2.7 Input Ports"
351
352  (with-test-prefix "open-file-input-port"
353    (test-input-file-opener open-file-input-port (test-file)))
354
355  ;; This section appears here so that it can use the binary input
356  ;; primitives.
357
358  (pass-if "open-bytevector-input-port [1 arg]"
359    (let* ((str "Hello Port!")
360           (bv (u8-list->bytevector (map char->integer
361                                         (string->list str))))
362           (port (open-bytevector-input-port bv))
363           (read-to-string
364            (lambda (port)
365              (let loop ((chr (read-char port))
366                         (result '()))
367                (if (eof-object? chr)
368                    (apply string (reverse! result))
369                    (loop (read-char port)
370                          (cons chr result)))))))
371
372      (equal? (read-to-string port) str)))
373
374  (pass-if "bytevector-input-port is binary"
375    (with-fluids ((%default-port-encoding "UTF-8"))
376      (binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
377
378  (pass-if-equal "bytevector-input-port uses ISO-8859-1 (Guile extension)"
379      "©©"
380    (with-fluids ((%default-port-encoding "UTF-8"))
381      (get-string-all (open-bytevector-input-port #vu8(194 169 194 169)))))
382
383  (pass-if-exception "bytevector-input-port is read-only"
384    exception:wrong-type-arg
385
386    (let* ((str "Hello Port!")
387           (bv (u8-list->bytevector (map char->integer
388                                         (string->list str))))
389           (port (open-bytevector-input-port bv #f)))
390
391      (write "hello" port)))
392
393  (pass-if "bytevector input port supports seeking"
394    (let* ((str "Hello Port!")
395           (bv (u8-list->bytevector (map char->integer
396                                         (string->list str))))
397           (port (open-bytevector-input-port bv #f)))
398
399      (and (port-has-port-position? port)
400           (= 0 (port-position port))
401           (port-has-set-port-position!? port)
402           (begin
403             (set-port-position! port 6)
404             (= 6 (port-position port)))
405           (bytevector=? (get-bytevector-all port)
406                         (u8-list->bytevector
407                          (map char->integer (string->list "Port!")))))))
408
409  (pass-if "bytevector input port can seek to very end"
410    (let ((empty (open-bytevector-input-port '#vu8()))
411          (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
412      (and (begin (set-port-position! empty (port-position empty))
413                  (= 0 (port-position empty)))
414           (begin (get-bytevector-n not-empty 3)
415                  (set-port-position! not-empty (port-position not-empty))
416                  (= 3 (port-position not-empty))))))
417
418  (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
419    exception:wrong-num-args
420
421    ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
422    ;; optional.
423    (make-custom-binary-input-port "port" (lambda args #t)))
424
425  (pass-if "make-custom-binary-input-port"
426    (let* ((source (make-bytevector 7777))
427           (read! (let ((pos 0)
428                        (len (bytevector-length source)))
429                    (lambda (bv start count)
430                      (let ((amount (min count (- len pos))))
431                        (if (> amount 0)
432                            (bytevector-copy! source pos
433                                              bv start amount))
434                        (set! pos (+ pos amount))
435                        amount))))
436           (port (make-custom-binary-input-port "the port" read!
437                                                #f #f #f)))
438
439      (and (binary-port? port)
440           (input-port? port)
441           (bytevector=? (get-bytevector-all port) source))))
442
443  (pass-if-equal "make-custom-binary-input-port uses ISO-8859-1 (Guile extension)"
444      "©©"
445    (with-fluids ((%default-port-encoding "UTF-8"))
446      (let* ((source #vu8(194 169 194 169))
447             (read! (let ((pos 0)
448                          (len (bytevector-length source)))
449                      (lambda (bv start count)
450                        (let ((amount (min count (- len pos))))
451                          (if (> amount 0)
452                              (bytevector-copy! source pos
453                                                bv start amount))
454                          (set! pos (+ pos amount))
455                          amount))))
456             (port (make-custom-binary-input-port "the port" read!
457                                                  #f #f #f)))
458        (get-string-all port))))
459
460  (pass-if "custom binary input port does not support `port-position'"
461    (let* ((str "Hello Port!")
462           (source (open-bytevector-input-port
463                    (u8-list->bytevector
464                     (map char->integer (string->list str)))))
465           (read! (lambda (bv start count)
466                    (let ((r (get-bytevector-n! source bv start count)))
467                      (if (eof-object? r)
468                          0
469                          r))))
470           (port (make-custom-binary-input-port "the port" read!
471                                                #f #f #f)))
472      (not (or (port-has-port-position? port)
473               (port-has-set-port-position!? port)))))
474
475  (pass-if-exception "custom binary input port 'read!' returns too much"
476      exception:out-of-range
477    ;; In Guile <= 2.0.9 this would segfault.
478    (let* ((read! (lambda (bv start count)
479                    (+ count 4242)))
480           (port (make-custom-binary-input-port "the port" read!
481                                                #f #f #f)))
482      (get-bytevector-all port)))
483
484  (pass-if-equal "custom binary input port supports `port-position', \
485not `set-port-position!'"
486      42
487    (let ((port (make-custom-binary-input-port "the port" (const 0)
488                                               (const 42) #f #f)))
489      (and (port-has-port-position? port)
490           (not (port-has-set-port-position!? port))
491           (port-position port))))
492
493  (pass-if "custom binary input port supports `port-position'"
494    (let* ((str "Hello Port!")
495           (source (open-bytevector-input-port
496                    (u8-list->bytevector
497                     (map char->integer (string->list str)))))
498           (read! (lambda (bv start count)
499                    (let ((r (get-bytevector-n! source bv start count)))
500                      (if (eof-object? r)
501                          0
502                          r))))
503           (get-pos (lambda ()
504                      (port-position source)))
505           (set-pos! (lambda (pos)
506                       (set-port-position! source pos)))
507           (port (make-custom-binary-input-port "the port" read!
508                                                get-pos set-pos! #f)))
509
510      (and (port-has-port-position? port)
511           (= 0 (port-position port))
512           (port-has-set-port-position!? port)
513           (begin
514             (set-port-position! port 6)
515             (= 6 (port-position port)))
516           (bytevector=? (get-bytevector-all port)
517                         (u8-list->bytevector
518                          (map char->integer (string->list "Port!")))))))
519
520  (pass-if-equal "custom binary input port position, long offset"
521      (expt 2 42)
522    ;; In Guile <= 2.2.4, 'seek' would throw to 'out-of-range'.
523    (let* ((port (make-custom-binary-input-port "the port"
524                                                (const 0)
525                                                (const (expt 2 42))
526                                                #f #f)))
527      (port-position port)))
528
529
530  (pass-if-equal "custom binary input port buffered partial reads"
531      "Hello Port!"
532    ;; Check what happens when READ! returns less than COUNT bytes.
533    (let* ((src    (string->utf8 "Hello Port!"))
534           (chunks '(2 4 5))                ; provide 2 bytes, then 4, etc.
535           (offset 0)
536           (read!  (lambda (bv start count)
537                     (match chunks
538                       ((count rest ...)
539                        (bytevector-copy! src offset bv start count)
540                        (set! chunks rest)
541                        (set! offset (+ offset count))
542                        count)
543                       (()
544                        0))))
545           (port   (make-custom-binary-input-port "the port"
546                                                  read! #f #f #f)))
547      (get-string-all port)))
548
549  (pass-if-equal "custom binary input port unbuffered & 'port-position'"
550      '(0 2 5 11)
551    ;; Check that the value returned by 'port-position' is correct, and
552    ;; that each 'port-position' call leads one call to the
553    ;; 'get-position' method.
554    (let* ((str    "Hello Port!")
555           (output (make-bytevector (string-length str)))
556           (source (with-fluids ((%default-port-encoding "UTF-8"))
557                     (open-string-input-port str)))
558           (read!  (lambda (bv start count)
559                     (let ((r (get-bytevector-n! source bv start count)))
560                       (if (eof-object? r)
561                           0
562                           r))))
563           (pos     '())
564           (get-pos (lambda ()
565                      (let ((p (port-position source)))
566                        (set! pos (cons p pos))
567                        p)))
568           (port    (make-custom-binary-input-port "the port" read!
569                                                   get-pos #f #f)))
570      (setvbuf port 'none)
571      (and (= 0 (port-position port))
572           (begin
573             (get-bytevector-n! port output 0 2)
574             (= 2 (port-position port)))
575           (begin
576             (get-bytevector-n! port output 2 3)
577             (= 5 (port-position port)))
578           (let ((bv (string->utf8 (get-string-all port))))
579             (bytevector-copy! bv 0 output 5 (bytevector-length bv))
580             (= (string-length str) (port-position port)))
581           (bytevector=? output (string->utf8 str))
582           (reverse pos))))
583
584  (pass-if-equal "custom binary input port unbuffered & 'read!' calls"
585      `((2 "He") (3 "llo") (42 " Port!"))
586    (let* ((str    "Hello Port!")
587           (source (with-fluids ((%default-port-encoding "UTF-8"))
588                     (open-string-input-port str)))
589           (reads  '())
590           (read!  (lambda (bv start count)
591                     (set! reads (cons count reads))
592                     (let ((r (get-bytevector-n! source bv start count)))
593                       (if (eof-object? r)
594                           0
595                           r))))
596           (port   (make-custom-binary-input-port "the port" read!
597                                                  #f #f #f)))
598
599      (setvbuf port 'none)
600      (let ((ret (list (get-bytevector-n port 2)
601                       (get-bytevector-n port 3)
602                       (get-bytevector-n port 42))))
603        (zip (reverse reads)
604             (map (lambda (obj)
605                    (if (bytevector? obj)
606                        (utf8->string obj)
607                        obj))
608                  ret)))))
609
610  (pass-if-equal "custom binary input port unbuffered & 'get-string-all'"
611      (make-string 1000 #\a)
612    ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
613    ;; by an assertion failure.  See <http://bugs.gnu.org/19621>.
614    (let* ((input (with-fluids ((%default-port-encoding #f))
615                    (open-input-string (make-string 1000 #\a))))
616           (read! (lambda (bv index count)
617                    (let ((n (get-bytevector-n! input bv index
618                                                count)))
619                      (if (eof-object? n) 0 n))))
620           (port  (make-custom-binary-input-port "foo" read!
621                                                 #f #f #f)))
622      (setvbuf port 'none)
623      (get-string-all port)))
624
625  (pass-if-equal "custom binary input port unbuffered UTF-8 & 'get-string-all'"
626      (make-string 1000 #\λ)
627    ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
628    ;; by an assertion failure.  See <http://bugs.gnu.org/19621>.
629    (let* ((input (with-fluids ((%default-port-encoding "UTF-8"))
630                    (open-input-string (make-string 1000 #\λ))))
631           (read! (lambda (bv index count)
632                    (let ((n (get-bytevector-n! input bv index
633                                                count)))
634                      (if (eof-object? n) 0 n))))
635           (port  (make-custom-binary-input-port "foo" read!
636                                                 #f #f #f)))
637      (setvbuf port 'none)
638      (set-port-encoding! port "UTF-8")
639      (get-string-all port)))
640
641  (pass-if-equal "custom binary input port, unbuffered then buffered"
642      `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
643        (777 ,(eof-object)))
644    (let* ((str    "Lorem ipsum dolor sit amet, consectetur…")
645           (source (with-fluids ((%default-port-encoding "UTF-8"))
646                     (open-string-input-port str)))
647           (reads  '())
648           (read!  (lambda (bv start count)
649                     (set! reads (cons count reads))
650                     (let ((r (get-bytevector-n! source bv start count)))
651                       (if (eof-object? r)
652                           0
653                           r))))
654           (port   (make-custom-binary-input-port "the port" read!
655                                                  #f #f #f)))
656
657      (setvbuf port 'none)
658      (let ((ret (list (get-bytevector-n port 6)
659                       (get-bytevector-n port 12)
660                       (begin
661                         (setvbuf port 'block 777)
662                         (get-bytevector-n port 42))
663                       (get-bytevector-n port 42))))
664        (zip (reverse reads)
665             (map (lambda (obj)
666                    (if (bytevector? obj)
667                        (utf8->string obj)
668                        obj))
669                  ret)))))
670
671  (pass-if-equal "custom binary input port, buffered then unbuffered"
672      `((18
673         42 14             ; scm_c_read tries to fill the 42-byte buffer
674         42)
675        ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
676    (let* ((str    "Lorem ipsum dolor sit amet, consectetur bla…")
677           (source (with-fluids ((%default-port-encoding "UTF-8"))
678                     (open-string-input-port str)))
679           (reads  '())
680           (read!  (lambda (bv start count)
681                     (set! reads (cons count reads))
682                     (let ((r (get-bytevector-n! source bv start count)))
683                       (if (eof-object? r)
684                           0
685                           r))))
686           (port   (make-custom-binary-input-port "the port" read!
687                                                  #f #f #f)))
688
689      (setvbuf port 'block 18)
690      (let ((ret (list (get-bytevector-n port 6)
691                       (get-bytevector-n port 12)
692                       (begin
693                         (setvbuf port 'none)
694                         (get-bytevector-n port 42))
695                       (get-bytevector-n port 42))))
696        (list (reverse reads)
697              (map (lambda (obj)
698                     (if (bytevector? obj)
699                         (utf8->string obj)
700                         obj))
701                   ret)))))
702
703  (pass-if "custom binary input port `close-proc' is called"
704    (let* ((closed?  #f)
705           (read!    (lambda (bv start count) 0))
706           (get-pos  (lambda () 0))
707           (set-pos! (lambda (pos) #f))
708           (close!   (lambda () (set! closed? #t)))
709           (port     (make-custom-binary-input-port "the port" read!
710                                                    get-pos set-pos!
711                                                    close!)))
712
713      (close-port port)
714      (gc) ; Test for marking a closed port.
715      closed?))
716
717  (pass-if "standard-input-port is binary"
718    (with-fluids ((%default-port-encoding "UTF-8"))
719      (binary-port? (standard-input-port)))))
720
721
722(define (test-output-file-opener open filename)
723  (with-fluids ((%default-port-encoding "UTF-8"))
724    (pass-if "opens binary output port"
725             (call-with-port (open filename)
726               (lambda (port)
727                 (put-bytevector port '#vu8(1 2 3))
728                 (and (binary-port? port)
729                      (output-port? port))))))
730
731  (pass-if-condition "exception: already-exists"
732                     i/o-file-already-exists-error?
733                     (open filename))
734
735  (pass-if "no-fail no-truncate"
736           (and
737             (call-with-port (open filename (file-options no-fail no-truncate))
738               (lambda (port)
739                 (= 0 (port-position port))))
740             (= 3 (stat:size (stat filename)))))
741
742  (pass-if "no-fail"
743           (and
744             (call-with-port (open filename (file-options no-fail))
745               binary-port?)
746             (= 0 (stat:size (stat filename)))))
747
748  (pass-if "buffer-mode none"
749           (call-with-port (open filename (file-options no-fail)
750                                 (buffer-mode none))
751             (lambda (port)
752               (eq? (output-port-buffer-mode port) 'none))))
753
754  (pass-if "buffer-mode line"
755           (call-with-port (open filename (file-options no-fail)
756                                 (buffer-mode line))
757             (lambda (port)
758               (eq? (output-port-buffer-mode port) 'line))))
759
760  (pass-if "buffer-mode block"
761           (call-with-port (open filename (file-options no-fail)
762                                 (buffer-mode block))
763             (lambda (port)
764               (eq? (output-port-buffer-mode port) 'block))))
765
766  (delete-file filename)
767
768  (pass-if-condition "exception: does-not-exist"
769                     i/o-file-does-not-exist-error?
770                     (open filename (file-options no-create))))
771
772(with-test-prefix "8.2.10 Output ports"
773
774  (with-test-prefix "open-file-output-port"
775    (test-output-file-opener open-file-output-port (test-file)))
776
777  (pass-if "open-string-output-port"
778    (call-with-values open-string-output-port
779      (lambda (port proc)
780        (and (port? port) (thunk? proc)))))
781
782  (pass-if-equal "calling string output port truncates port"
783      '("hello" "" "world")
784    (call-with-values open-string-output-port
785      (lambda (port proc)
786        (display "hello" port)
787        (let* ((s1 (proc))
788               (s2 (proc)))
789          (display "world" port)
790          (list s1 s2 (proc))))))
791
792  (pass-if "open-bytevector-output-port"
793    (let-values (((port get-content)
794                  (open-bytevector-output-port #f)))
795      (let ((source (make-bytevector 7777)))
796        (put-bytevector port source)
797        (and (bytevector=? (get-content) source)
798             (bytevector=? (get-content) (make-bytevector 0))))))
799
800  (pass-if "bytevector-output-port is binary"
801    (binary-port? (open-bytevector-output-port)))
802
803  (pass-if-equal "bytevector-output-port uses ISO-8859-1 (Guile extension)"
804      #vu8(194 169 194 169)
805    (with-fluids ((%default-port-encoding "UTF-8"))
806      (let-values (((port get-content)
807                    (open-bytevector-output-port)))
808        (put-string port "©©")
809        (get-content))))
810
811  (pass-if "open-bytevector-output-port [extract after close]"
812    (let-values (((port get-content)
813                  (open-bytevector-output-port)))
814      (let ((source (make-bytevector 12345 #xFE)))
815        (put-bytevector port source)
816        (close-port port)
817        (bytevector=? (get-content) source))))
818
819  (pass-if "open-bytevector-output-port [put-u8]"
820    (let-values (((port get-content)
821                  (open-bytevector-output-port)))
822      (put-u8 port 77)
823      (and (bytevector=? (get-content) (make-bytevector 1 77))
824           (bytevector=? (get-content) (make-bytevector 0)))))
825
826  (pass-if "open-bytevector-output-port [display]"
827    (let-values (((port get-content)
828                  (open-bytevector-output-port)))
829      (display "hello" port)
830      (and (bytevector=? (get-content) (string->utf8 "hello"))
831           (bytevector=? (get-content) (make-bytevector 0)))))
832
833  (pass-if "bytevector output port supports `port-position'"
834    (let-values (((port get-content)
835                  (open-bytevector-output-port)))
836      (let ((source (make-bytevector 7777))
837            (overwrite (make-bytevector 33)))
838        (and (port-has-port-position? port)
839             (port-has-set-port-position!? port)
840             (begin
841               (put-bytevector port source)
842               (= (bytevector-length source)
843                  (port-position port)))
844             (begin
845               (set-port-position! port 10)
846               (= 10 (port-position port)))
847             (begin
848               (put-bytevector port overwrite)
849               (bytevector-copy! overwrite 0 source 10
850                                 (bytevector-length overwrite))
851               (= (port-position port)
852                  (+ 10 (bytevector-length overwrite))))
853             (bytevector=? (get-content) source)
854             (bytevector=? (get-content) (make-bytevector 0))))))
855
856  (pass-if "make-custom-binary-output-port"
857    (let ((port (make-custom-binary-output-port "cbop"
858                                                (lambda (x y z) 0)
859                                                #f #f #f)))
860      (and (output-port? port)
861           (binary-port? port)
862           (not (port-has-port-position? port))
863           (not (port-has-set-port-position!? port)))))
864
865  (pass-if "make-custom-binary-output-port [partial writes]"
866    (let* ((source   (uint-list->bytevector (iota 333)
867                                            (native-endianness) 2))
868           (sink     (make-bytevector (bytevector-length source)))
869           (sink-pos 0)
870           (eof?     #f)
871           (write!   (lambda (bv start count)
872                       (if (= 0 count)
873                           (begin
874                             (set! eof? #t)
875                             0)
876                           (let ((u8 (bytevector-u8-ref bv start)))
877                             ;; Get one byte at a time.
878                             (bytevector-u8-set! sink sink-pos u8)
879                             (set! sink-pos (+ 1 sink-pos))
880                             1))))
881           (port     (make-custom-binary-output-port "cbop" write!
882                                                     #f #f #f)))
883      (put-bytevector port source)
884      (force-output port)
885      (and (= sink-pos (bytevector-length source))
886           (not eof?)
887           (bytevector=? sink source))))
888
889  (pass-if "make-custom-binary-output-port [full writes]"
890    (let* ((source   (uint-list->bytevector (iota 333)
891                                            (native-endianness) 2))
892           (sink     (make-bytevector (bytevector-length source)))
893           (sink-pos 0)
894           (eof?     #f)
895           (write!   (lambda (bv start count)
896                       (if (= 0 count)
897                           (begin
898                             (set! eof? #t)
899                             0)
900                           (begin
901                             (bytevector-copy! bv start
902                                               sink sink-pos
903                                               count)
904                             (set! sink-pos (+ sink-pos count))
905                             count))))
906           (port     (make-custom-binary-output-port "cbop" write!
907                                                     #f #f #f)))
908      (put-bytevector port source)
909      (force-output port)
910      (and (= sink-pos (bytevector-length source))
911           (not eof?)
912           (bytevector=? sink source))))
913
914  (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)"
915      '(194 169 194 169)
916    (with-fluids ((%default-port-encoding "UTF-8"))
917      (let* ((sink '())
918             (write! (lambda (bv start count)
919                       (if (= 0 count)  ; EOF
920                           0
921                           (let ((u8 (bytevector-u8-ref bv start)))
922                             ;; Get one byte at a time.
923                             (set! sink (cons u8 sink))
924                             1))))
925             (port (make-custom-binary-output-port "cbop" write!
926                                                   #f #f #f)))
927      (put-string port "©©")
928      (force-output port)
929      (reverse sink))))
930
931  (pass-if "standard-output-port is binary"
932    (with-fluids ((%default-port-encoding "UTF-8"))
933      (binary-port? (standard-output-port))))
934
935  (pass-if "standard-error-port is binary"
936    (with-fluids ((%default-port-encoding "UTF-8"))
937      (binary-port? (standard-error-port)))))
938
939
940(with-test-prefix "8.2.6  Input and output ports"
941
942  (define (check-transcoded-port-mode make-port pred)
943    (let ((p (make-port "/dev/null" (file-options no-fail))))
944      (dynamic-wind
945        (lambda () #t)
946        (lambda ()
947          (set! p (transcoded-port p (native-transcoder)))
948          (pred p))
949        (lambda () (close-port p)))))
950
951  (pass-if "transcoded-port preserves input mode"
952    (check-transcoded-port-mode open-file-input-port
953                                (lambda (p)
954                                  (and (input-port? p)
955                                       (not (output-port? p))))))
956
957  (pass-if "transcoded-port preserves output mode"
958    (check-transcoded-port-mode open-file-output-port
959                                (lambda (p)
960                                  (and (not (input-port? p))
961                                       (output-port? p)))))
962
963  (pass-if "transcoded-port preserves input/output mode"
964    (check-transcoded-port-mode open-file-input/output-port
965                                (lambda (p)
966                                  (and (input-port? p) (output-port? p)))))
967
968  (pass-if "transcoded-port [output]"
969    (let ((s "Hello\nÄÖÜ"))
970      (bytevector=?
971       (string->utf8 s)
972       (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
973         (lambda (utf8-port)
974           (put-string utf8-port s))))))
975
976  (pass-if "transcoded-port [input]"
977    (let ((s "Hello\nÄÖÜ"))
978      (string=?
979       s
980       (get-string-all
981        (transcoded-port (open-bytevector-input-port (string->utf8 s))
982                         (make-transcoder (utf-8-codec)))))))
983
984  (pass-if "transcoded-port [input line]"
985    (string=? "ÄÖÜ"
986              (get-line (transcoded-port
987                         (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
988                         (make-transcoder (utf-8-codec))))))
989
990  (pass-if "transcoded-port [error handling mode = raise]"
991    (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
992                                (error-handling-mode raise)))
993           (b  (open-bytevector-input-port #vu8(255 2 1)))
994           (tp (transcoded-port b t)))
995      (guard (c ((i/o-decoding-error? c)
996                 (eq? (i/o-error-port c) tp)))
997        (get-line tp)
998        #f)))                              ; fail if we reach this point
999
1000  (pass-if "transcoded-port [error handling mode = replace]"
1001    (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
1002                                (error-handling-mode replace)))
1003           (b  (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
1004           (tp (transcoded-port b t)))
1005      (string-suffix? "gnu" (get-line tp))))
1006
1007  (pass-if "transcoded-port, output [error handling mode = raise]"
1008    (let-values (((p get)
1009                  (open-bytevector-output-port)))
1010      (let* ((t  (make-transcoder (latin-1-codec) (native-eol-style)
1011                                  (error-handling-mode raise)))
1012             (tp (transcoded-port p t)))
1013        (setvbuf tp 'none)
1014        (guard (c ((i/o-encoding-error? c)
1015                   (and (eq? (i/o-error-port c) tp)
1016                        (char=? (i/o-encoding-error-char c) #\λ)
1017                        (bytevector=? (get) (string->utf8 "The letter ")))))
1018          (put-string tp "The letter λ cannot be represented in Latin-1.")
1019          #f))))
1020
1021  (pass-if "port-transcoder [transcoded port]"
1022    (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
1023                               (make-transcoder (utf-8-codec))))
1024           (t (port-transcoder p)))
1025      (and t
1026           (transcoder-codec t)
1027           (eq? (native-eol-style)
1028                (transcoder-eol-style t))
1029           (eq? (error-handling-mode replace)
1030                (transcoder-error-handling-mode t))))))
1031
1032(with-test-prefix "8.2.9  Textual input"
1033
1034  (pass-if "get-string-n [short]"
1035    (let ((port (open-input-string "GNU Guile")))
1036      (string=? "GNU " (get-string-n port 4))))
1037  (pass-if "get-string-n [long]"
1038    (let ((port (open-input-string "GNU Guile")))
1039      (string=? "GNU Guile" (get-string-n port 256))))
1040  (pass-if "get-string-n [eof]"
1041    (let ((port (open-input-string "")))
1042      (eof-object? (get-string-n port 4))))
1043
1044  (pass-if "get-string-n! [short]"
1045    (let ((port (open-input-string "GNU Guile"))
1046          (s (string-copy "Isn't XXX great?")))
1047      (and (= 3 (get-string-n! port s 6 3))
1048           (string=? s "Isn't GNU great?"))))
1049
1050  (with-test-prefix "read error"
1051    (pass-if-condition "get-char" i/o-read-error?
1052      (get-char (make-failing-port)))
1053    (pass-if-condition "lookahead-char" i/o-read-error?
1054      (lookahead-char (make-failing-port)))
1055    ;; FIXME: these are not yet exception-correct
1056    #|
1057    (pass-if-condition "get-string-n" i/o-read-error?
1058      (get-string-n (make-failing-port) 5))
1059    (pass-if-condition "get-string-n!" i/o-read-error?
1060      (get-string-n! (make-failing-port) (make-string 5) 0 5))
1061    |#
1062    (pass-if-condition "get-string-all" i/o-read-error?
1063      (get-string-all (make-failing-port 100)))
1064    (pass-if-condition "get-line" i/o-read-error?
1065      (get-line (make-failing-port)))
1066    (pass-if-condition "get-datum" i/o-read-error?
1067      (get-datum (make-failing-port)))))
1068
1069(define (encoding-error-predicate char)
1070  (lambda (c)
1071    (and (i/o-encoding-error? c)
1072         (char=? char (i/o-encoding-error-char c)))))
1073
1074(with-test-prefix "8.2.12 Textual Output"
1075
1076  (with-test-prefix "write error"
1077    (pass-if-condition "put-char" i/o-write-error?
1078      (put-char (make-failing-port) #\G))
1079    (pass-if-condition "put-string" i/o-write-error?
1080      (put-string (make-failing-port) "Hello World!"))
1081    (pass-if-condition "put-datum" i/o-write-error?
1082      (put-datum (make-failing-port) '(hello world!))))
1083  (with-test-prefix "encoding error"
1084    (pass-if-condition "put-char" (encoding-error-predicate #\λ)
1085      (call-with-bytevector-output-port/transcoded
1086          (make-transcoder (latin-1-codec)
1087                           (native-eol-style)
1088                           (error-handling-mode raise))
1089        (lambda (port)
1090          (put-char port #\λ))))
1091    (pass-if-condition "put-string" (encoding-error-predicate #\λ)
1092      (call-with-bytevector-output-port/transcoded
1093          (make-transcoder (latin-1-codec)
1094                           (native-eol-style)
1095                           (error-handling-mode raise))
1096        (lambda (port)
1097          (put-string port "FooλBar"))))))
1098
1099(with-test-prefix "8.3 Simple I/O"
1100  (with-test-prefix "read error"
1101    (pass-if-condition "read-char" i/o-read-error?
1102      (read-char (make-failing-port)))
1103    (pass-if-condition "peek-char" i/o-read-error?
1104      (peek-char (make-failing-port)))
1105    (pass-if-condition "read" i/o-read-error?
1106      (read (make-failing-port))))
1107  (with-test-prefix "write error"
1108    (pass-if-condition "display" i/o-write-error?
1109      (display "Hi there!" (make-failing-port)))
1110    (pass-if-condition "write" i/o-write-error?
1111      (write '(hi there!) (make-failing-port)))
1112    (pass-if-condition "write-char" i/o-write-error?
1113      (write-char #\G (make-failing-port)))
1114    (pass-if-condition "newline" i/o-write-error?
1115      (newline (make-failing-port))))
1116  (let ((filename (test-file)))
1117    ;; ensure the test file exists
1118    (call-with-output-file filename
1119      (lambda (port) (write "foo" port)))
1120    (pass-if "call-with-input-file [port is textual]"
1121      (call-with-input-file filename textual-port?))
1122    (pass-if-condition "call-with-input-file [exception: not-found]"
1123        i/o-file-does-not-exist-error?
1124      (call-with-input-file ",this-is-highly-unlikely-to-exist!"
1125        values))
1126    (pass-if-condition "call-with-output-file [exception: already-exists]"
1127        i/o-file-already-exists-error?
1128      (call-with-output-file filename
1129        values))
1130    (delete-file filename)))
1131
1132;; Used for a lot of the make-custom-input/output tests to stub out
1133;; the read/write section for whatever part we're ignoring
1134(define dummy-write! (const 0))
1135(define dummy-read! (const 0))
1136
1137(with-test-prefix "8.2.13 Input/output ports"
1138  (with-test-prefix "open-file-input/output-port [output]"
1139    (test-output-file-opener open-file-input/output-port (test-file)))
1140  (with-test-prefix "open-file-input/output-port [input]"
1141    (test-input-file-opener open-file-input/output-port (test-file)))
1142
1143  ;; Custom binary input/output tests.  Most of these are simple
1144  ;; ports of the custom-binary-input-port tests or custom-binary-ouput-port
1145  ;; tests, simply ported to use a custom-binary-input/output port.
1146  ;; The copy-pasta is strong here; a diet lighter in spaghetti may wish
1147  ;; to make the previous tests more reusable.
1148  (pass-if "make-custom-binary-input/output-port"
1149    (let* ((source (make-bytevector 7777))
1150           (read! (let ((pos 0)
1151                        (len (bytevector-length source)))
1152                    (lambda (bv start count)
1153                      (let ((amount (min count (- len pos))))
1154                        (if (> amount 0)
1155                            (bytevector-copy! source pos
1156                                              bv start amount))
1157                        (set! pos (+ pos amount))
1158                        amount))))
1159           (write! (lambda (x y z) 0))
1160           (port (make-custom-binary-input/output-port
1161                  "the port" read! write!
1162                  #f #f #f)))
1163      (and (binary-port? port)
1164           (input-port? port)
1165           (output-port? port)
1166           (bytevector=? (get-bytevector-all port) source)
1167           (not (port-has-port-position? port))
1168           (not (port-has-set-port-position!? port)))))
1169
1170  (pass-if-equal "make-custom-binary-input/output-port uses ISO-8859-1 (Guile \
1171extension) [input]"
1172      "©©"
1173    (with-fluids ((%default-port-encoding "UTF-8"))
1174      (let* ((source #vu8(194 169 194 169))
1175             (read! (let ((pos 0)
1176                          (len (bytevector-length source)))
1177                      (lambda (bv start count)
1178                        (let ((amount (min count (- len pos))))
1179                          (if (> amount 0)
1180                              (bytevector-copy! source pos
1181                                                bv start amount))
1182                          (set! pos (+ pos amount))
1183                          amount))))
1184             (port (make-custom-binary-input/output-port
1185                    "the port" read! dummy-write!
1186                    #f #f #f)))
1187        (get-string-all port))))
1188
1189  (pass-if "custom binary input/output port does not support `port-position'"
1190    (let* ((str "Hello Port!")
1191           (source (open-bytevector-input-port
1192                    (u8-list->bytevector
1193                     (map char->integer (string->list str)))))
1194           (read! (lambda (bv start count)
1195                    (let ((r (get-bytevector-n! source bv start count)))
1196                      (if (eof-object? r)
1197                          0
1198                          r))))
1199           (port (make-custom-binary-input/output-port
1200                  "the port" read! dummy-write!
1201                  #f #f #f)))
1202      (not (or (port-has-port-position? port)
1203               (port-has-set-port-position!? port)))))
1204
1205  (pass-if-exception "custom binary input/output port 'read!' returns too much"
1206      exception:out-of-range
1207    ;; In Guile <= 2.0.9 this would segfault.
1208    (let* ((read! (lambda (bv start count)
1209                    (+ count 4242)))
1210           (port (make-custom-binary-input/output-port
1211                  "the port" read! dummy-write!
1212                  #f #f #f)))
1213      (get-bytevector-all port)))
1214
1215  (pass-if-equal "custom binary input/output port supports `port-position', \
1216not `set-port-position!'"
1217      42
1218    (let ((port (make-custom-binary-input/output-port
1219                 "the port" (const 0) dummy-write!
1220                 (const 42) #f #f)))
1221      (and (port-has-port-position? port)
1222           (not (port-has-set-port-position!? port))
1223           (port-position port))))
1224
1225  (pass-if "custom binary input/output port supports `port-position'"
1226    (let* ((str "Hello Port!")
1227           (source (open-bytevector-input-port
1228                    (u8-list->bytevector
1229                     (map char->integer (string->list str)))))
1230           (read! (lambda (bv start count)
1231                    (let ((r (get-bytevector-n! source bv start count)))
1232                      (if (eof-object? r)
1233                          0
1234                          r))))
1235           (get-pos (lambda ()
1236                      (port-position source)))
1237           (set-pos! (lambda (pos)
1238                       (set-port-position! source pos)))
1239           (port (make-custom-binary-input/output-port
1240                  "the port" read! dummy-write!
1241                  get-pos set-pos! #f)))
1242
1243      (and (port-has-port-position? port)
1244           (= 0 (port-position port))
1245           (port-has-set-port-position!? port)
1246           (begin
1247             (set-port-position! port 6)
1248             (= 6 (port-position port)))
1249           (bytevector=? (get-bytevector-all port)
1250                         (u8-list->bytevector
1251                          (map char->integer (string->list "Port!")))))))
1252
1253  (pass-if-equal "custom binary input/output port buffered partial reads"
1254      "Hello Port!"
1255    ;; Check what happens when READ! returns less than COUNT bytes.
1256    (let* ((src    (string->utf8 "Hello Port!"))
1257           (chunks '(2 4 5))                ; provide 2 bytes, then 4, etc.
1258           (offset 0)
1259           (read!  (lambda (bv start count)
1260                     (match chunks
1261                       ((count rest ...)
1262                        (bytevector-copy! src offset bv start count)
1263                        (set! chunks rest)
1264                        (set! offset (+ offset count))
1265                        count)
1266                       (()
1267                        0))))
1268           (port   (make-custom-binary-input/output-port
1269                    "the port" read! dummy-write!
1270                    #f #f #f)))
1271      (get-string-all port)))
1272
1273  (pass-if-equal "custom binary input/output port unbuffered & 'port-position'"
1274      '(0 2 5 11)
1275    ;; Check that the value returned by 'port-position' is correct, and
1276    ;; that each 'port-position' call leads one call to the
1277    ;; 'get-position' method.
1278    (let* ((str    "Hello Port!")
1279           (output (make-bytevector (string-length str)))
1280           (source (with-fluids ((%default-port-encoding "UTF-8"))
1281                     (open-string-input-port str)))
1282           (read!  (lambda (bv start count)
1283                     (let ((r (get-bytevector-n! source bv start count)))
1284                       (if (eof-object? r)
1285                           0
1286                           r))))
1287           (pos     '())
1288           (get-pos (lambda ()
1289                      (let ((p (port-position source)))
1290                        (set! pos (cons p pos))
1291                        p)))
1292           (port    (make-custom-binary-input/output-port
1293                     "the port" read! dummy-write!
1294                     get-pos #f #f)))
1295      (setvbuf port 'none)
1296      (and (= 0 (port-position port))
1297           (begin
1298             (get-bytevector-n! port output 0 2)
1299             (= 2 (port-position port)))
1300           (begin
1301             (get-bytevector-n! port output 2 3)
1302             (= 5 (port-position port)))
1303           (let ((bv (string->utf8 (get-string-all port))))
1304             (bytevector-copy! bv 0 output 5 (bytevector-length bv))
1305             (= (string-length str) (port-position port)))
1306           (bytevector=? output (string->utf8 str))
1307           (reverse pos))))
1308
1309  (pass-if-equal "custom binary input/output port unbuffered & 'read!' calls"
1310      `((2 "He") (3 "llo") (42 " Port!"))
1311    (let* ((str    "Hello Port!")
1312           (source (with-fluids ((%default-port-encoding "UTF-8"))
1313                     (open-string-input-port str)))
1314           (reads  '())
1315           (read!  (lambda (bv start count)
1316                     (set! reads (cons count reads))
1317                     (let ((r (get-bytevector-n! source bv start count)))
1318                       (if (eof-object? r)
1319                           0
1320                           r))))
1321           (port   (make-custom-binary-input/output-port
1322                    "the port" read! dummy-write!
1323                    #f #f #f)))
1324
1325      (setvbuf port 'none)
1326      (let ((ret (list (get-bytevector-n port 2)
1327                       (get-bytevector-n port 3)
1328                       (get-bytevector-n port 42))))
1329        (zip (reverse reads)
1330             (map (lambda (obj)
1331                    (if (bytevector? obj)
1332                        (utf8->string obj)
1333                        obj))
1334                  ret)))))
1335
1336  (pass-if-equal "custom binary input/output port unbuffered & 'get-string-all'"
1337      (make-string 1000 #\a)
1338    ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
1339    ;; by an assertion failure.  See <http://bugs.gnu.org/19621>.
1340    (let* ((input (with-fluids ((%default-port-encoding #f))
1341                    (open-input-string (make-string 1000 #\a))))
1342           (read! (lambda (bv index count)
1343                    (let ((n (get-bytevector-n! input bv index
1344                                                count)))
1345                      (if (eof-object? n) 0 n))))
1346           (port  (make-custom-binary-input/output-port
1347                   "foo" read! dummy-write!
1348                   #f #f #f)))
1349      (setvbuf port 'none)
1350      (get-string-all port)))
1351
1352  (pass-if-equal "custom binary input/output port unbuffered UTF-8 & \
1353'get-string-all'"
1354      (make-string 1000 #\λ)
1355    ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
1356    ;; by an assertion failure.  See <http://bugs.gnu.org/19621>.
1357    (let* ((input (with-fluids ((%default-port-encoding "UTF-8"))
1358                    (open-input-string (make-string 1000 #\λ))))
1359           (read! (lambda (bv index count)
1360                    (let ((n (get-bytevector-n! input bv index
1361                                                count)))
1362                      (if (eof-object? n) 0 n))))
1363           (port  (make-custom-binary-input/output-port
1364                   "foo" read! dummy-write!
1365                   #f #f #f)))
1366      (setvbuf port 'none)
1367      (set-port-encoding! port "UTF-8")
1368      (get-string-all port)))
1369
1370  (pass-if-equal "custom binary input/output port, unbuffered then buffered"
1371      `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
1372        (777 ,(eof-object)))
1373    (let* ((str    "Lorem ipsum dolor sit amet, consectetur…")
1374           (source (with-fluids ((%default-port-encoding "UTF-8"))
1375                     (open-string-input-port str)))
1376           (reads  '())
1377           (read!  (lambda (bv start count)
1378                     (set! reads (cons count reads))
1379                     (let ((r (get-bytevector-n! source bv start count)))
1380                       (if (eof-object? r)
1381                           0
1382                           r))))
1383           (port   (make-custom-binary-input/output-port
1384                    "the port" read! dummy-write!
1385                    #f #f #f)))
1386
1387      (setvbuf port 'none)
1388      (let ((ret (list (get-bytevector-n port 6)
1389                       (get-bytevector-n port 12)
1390                       (begin
1391                         (setvbuf port 'block 777)
1392                         (get-bytevector-n port 42))
1393                       (get-bytevector-n port 42))))
1394        (zip (reverse reads)
1395             (map (lambda (obj)
1396                    (if (bytevector? obj)
1397                        (utf8->string obj)
1398                        obj))
1399                  ret)))))
1400
1401  (pass-if-equal "custom binary input/output port, buffered then unbuffered"
1402      `((18
1403         42 14             ; scm_c_read tries to fill the 42-byte buffer
1404         42)
1405        ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
1406    (let* ((str    "Lorem ipsum dolor sit amet, consectetur bla…")
1407           (source (with-fluids ((%default-port-encoding "UTF-8"))
1408                     (open-string-input-port str)))
1409           (reads  '())
1410           (read!  (lambda (bv start count)
1411                     (set! reads (cons count reads))
1412                     (let ((r (get-bytevector-n! source bv start count)))
1413                       (if (eof-object? r)
1414                           0
1415                           r))))
1416           (port   (make-custom-binary-input/output-port
1417                    "the port" read! dummy-write!
1418                    #f #f #f)))
1419
1420      (setvbuf port 'block 18)
1421      (let ((ret (list (get-bytevector-n port 6)
1422                       (get-bytevector-n port 12)
1423                       (begin
1424                         (setvbuf port 'none)
1425                         (get-bytevector-n port 42))
1426                       (get-bytevector-n port 42))))
1427        (list (reverse reads)
1428              (map (lambda (obj)
1429                     (if (bytevector? obj)
1430                         (utf8->string obj)
1431                         obj))
1432                   ret)))))
1433
1434  (pass-if "custom binary input/output port `close-proc' is called"
1435    (let* ((closed?  #f)
1436           (read!    (lambda (bv start count) 0))
1437           (get-pos  (lambda () 0))
1438           (set-pos! (lambda (pos) #f))
1439           (close!   (lambda () (set! closed? #t)))
1440           (port     (make-custom-binary-input/output-port
1441                      "the port" read! dummy-write!
1442                      get-pos set-pos! close!)))
1443
1444      (close-port port)
1445      (gc) ; Test for marking a closed port.
1446      closed?))
1447
1448  (pass-if "make-custom-binary-input/output-port [partial writes]"
1449    (let* ((source   (uint-list->bytevector (iota 333)
1450                                            (native-endianness) 2))
1451           (sink     (make-bytevector (bytevector-length source)))
1452           (sink-pos 0)
1453           (eof?     #f)
1454           (write!   (lambda (bv start count)
1455                       (if (= 0 count)
1456                           (begin
1457                             (set! eof? #t)
1458                             0)
1459                           (let ((u8 (bytevector-u8-ref bv start)))
1460                             ;; Get one byte at a time.
1461                             (bytevector-u8-set! sink sink-pos u8)
1462                             (set! sink-pos (+ 1 sink-pos))
1463                             1))))
1464           (port     (make-custom-binary-input/output-port
1465                      "cbop" dummy-read! write!
1466                      #f #f #f)))
1467      (put-bytevector port source)
1468      (force-output port)
1469      (and (= sink-pos (bytevector-length source))
1470           (not eof?)
1471           (bytevector=? sink source))))
1472
1473  (pass-if "make-custom-binary-input/output-port [full writes]"
1474    (let* ((source   (uint-list->bytevector (iota 333)
1475                                            (native-endianness) 2))
1476           (sink     (make-bytevector (bytevector-length source)))
1477           (sink-pos 0)
1478           (eof?     #f)
1479           (write!   (lambda (bv start count)
1480                       (if (= 0 count)
1481                           (begin
1482                             (set! eof? #t)
1483                             0)
1484                           (begin
1485                             (bytevector-copy! bv start
1486                                               sink sink-pos
1487                                               count)
1488                             (set! sink-pos (+ sink-pos count))
1489                             count))))
1490           (port     (make-custom-binary-input/output-port
1491                      "cbop" dummy-read! write!
1492                      #f #f #f)))
1493      (put-bytevector port source)
1494      (force-output port)
1495      (and (= sink-pos (bytevector-length source))
1496           (not eof?)
1497           (bytevector=? sink source))))
1498
1499  (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)\
1500 [output]"
1501      '(194 169 194 169)
1502    (with-fluids ((%default-port-encoding "UTF-8"))
1503      (let* ((sink '())
1504             (write! (lambda (bv start count)
1505                       (if (= 0 count)  ; EOF
1506                           0
1507                           (let ((u8 (bytevector-u8-ref bv start)))
1508                             ;; Get one byte at a time.
1509                             (set! sink (cons u8 sink))
1510                             1))))
1511             (port (make-custom-binary-input/output-port
1512                    "cbop" dummy-read! write!
1513                    #f #f #f)))
1514      (put-string port "©©")
1515      (force-output port)
1516      (reverse sink))))
1517  )
1518
1519(define exception:encoding-error
1520  '(encoding-error . ""))
1521
1522(define exception:decoding-error
1523  '(decoding-error . ""))
1524
1525
1526(with-test-prefix "ascii string"
1527  (let ((s "Hello, World!"))
1528    ;; For ASCII, all of these encodings should be the same.
1529
1530    (pass-if "to ascii bytevector"
1531      (equal? (string->bytevector s (make-transcoder "ASCII"))
1532              #vu8(72 101 108 108 111 44 32 87 111 114 108 100 33)))
1533
1534    (pass-if "to ascii bytevector (length check)"
1535      (equal? (string-length s)
1536              (bytevector-length
1537               (string->bytevector s (make-transcoder "ascii")))))
1538
1539    (pass-if "from ascii bytevector"
1540      (equal? s
1541              (bytevector->string
1542               (string->bytevector s (make-transcoder "ascii"))
1543               (make-transcoder "ascii"))))
1544
1545    (pass-if "to utf-8 bytevector"
1546      (equal? (string->bytevector s (make-transcoder "ASCII"))
1547              (string->bytevector s (make-transcoder "utf-8"))))
1548
1549    (pass-if "to UTF-8 bytevector (testing encoding case sensitivity)"
1550      (equal? (string->bytevector s (make-transcoder "ascii"))
1551              (string->bytevector s (make-transcoder "UTF-8"))))
1552
1553    (pass-if "from utf-8 bytevector"
1554      (equal? s
1555              (bytevector->string
1556               (string->bytevector s (make-transcoder "utf-8"))
1557               (make-transcoder "utf-8"))))
1558
1559    (pass-if "to latin1 bytevector"
1560      (equal? (string->bytevector s (make-transcoder "ASCII"))
1561              (string->bytevector s (make-transcoder "latin1"))))
1562
1563    (pass-if "from latin1 bytevector"
1564      (equal? s
1565              (bytevector->string
1566               (string->bytevector s (make-transcoder "utf-8"))
1567               (make-transcoder "utf-8"))))))
1568
1569(with-test-prefix "narrow non-ascii string"
1570  (let ((s "été"))
1571    (pass-if "to latin1 bytevector"
1572      (equal? (string->bytevector s (make-transcoder "latin1"))
1573              #vu8(233 116 233)))
1574
1575    (pass-if "to latin1 bytevector (length check)"
1576      (equal? (string-length s)
1577              (bytevector-length
1578               (string->bytevector s (make-transcoder "latin1")))))
1579
1580    (pass-if "from latin1 bytevector"
1581      (equal? s
1582              (bytevector->string
1583               (string->bytevector s (make-transcoder "latin1"))
1584               (make-transcoder "latin1"))))
1585
1586    (pass-if "to utf-8 bytevector"
1587      (equal? (string->bytevector s (make-transcoder "utf-8"))
1588              #vu8(195 169 116 195 169)))
1589
1590    (pass-if "from utf-8 bytevector"
1591      (equal? s
1592              (bytevector->string
1593               (string->bytevector s (make-transcoder "utf-8"))
1594               (make-transcoder "utf-8"))))
1595
1596    (pass-if-exception "encode latin1 as ascii" exception:encoding-error
1597      (string->bytevector s (make-transcoder "ascii"
1598                                             (native-eol-style)
1599                                             (error-handling-mode raise))))
1600
1601    (pass-if-exception "misparse latin1 as utf8" exception:decoding-error
1602      (bytevector->string
1603       (string->bytevector s (make-transcoder "latin1"))
1604       (make-transcoder "utf-8"
1605                        (native-eol-style)
1606                        (error-handling-mode raise))))
1607
1608    (pass-if "misparse latin1 as utf8 with substitutions"
1609      (equal? (bytevector->string
1610               (string->bytevector s (make-transcoder "latin1"))
1611               (make-transcoder "utf-8" (native-eol-style)
1612                                (error-handling-mode replace)))
1613              "\uFFFDt\uFFFD"))
1614
1615    (pass-if-exception "misparse latin1 as ascii" exception:decoding-error
1616      (bytevector->string (string->bytevector s (make-transcoder "latin1"))
1617                          (make-transcoder "ascii"
1618                                           (native-eol-style)
1619                                           (error-handling-mode raise))))))
1620
1621
1622(with-test-prefix "wide non-ascii string"
1623  (let ((s "ΧΑΟΣ"))
1624    (pass-if "to utf-8 bytevector"
1625      (equal? (string->bytevector s (make-transcoder "utf-8"))
1626              #vu8(206 167 206 145 206 159 206 163) ))
1627
1628    (pass-if "from utf-8 bytevector"
1629      (equal? s
1630              (bytevector->string
1631               (string->bytevector s (make-transcoder "utf-8"))
1632               (make-transcoder "utf-8"))))
1633
1634    (pass-if-exception "encode as ascii" exception:encoding-error
1635      (string->bytevector s (make-transcoder "ascii"
1636                                             (native-eol-style)
1637                                             (error-handling-mode raise))))
1638
1639    (pass-if-exception "encode as latin1" exception:encoding-error
1640      (string->bytevector s (make-transcoder "latin1"
1641                                             (native-eol-style)
1642                                             (error-handling-mode raise))))
1643
1644    (pass-if "encode as ascii with substitutions"
1645      (equal? (make-string (string-length s) #\?)
1646              (bytevector->string
1647               (string->bytevector s (make-transcoder
1648                                      "ascii"
1649                                      (native-eol-style)
1650                                      (error-handling-mode replace)))
1651               (make-transcoder "ascii"))))))
1652
1653;;; Local Variables:
1654;;; mode: scheme
1655;;; eval: (put 'guard 'scheme-indent-function 1)
1656;;; End:
1657