mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +02:00
Code Activity

Update tests to use new soft ports interface.

Browse source 
* test-suite/tests/r6rs-ports.test:
* test-suite/tests/web-client.test:
* test-suite/tests/ports.test ("pending EOF behavior"):
("unicode byte-order marks (BOMs)"): Use new soft ports.
This commit is contained in:
Andy Wingo 2025-05-05 11:45:31 +02:00
parent c1caabaa24
commit 4c2a8c1dd3
3 changed files with 50 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

21
test-suite/tests/ports.test
View file

@ -23,6 +23,7 @@
#:use-module (test-suite guile-test)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 soft-ports)
#:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port
@ -1598,16 +1599,11 @@
;; Make a test port that will produce the given sequence. Each
;; element of 'lst' may be either a character or #f (which means EOF).
(define (test-soft-port . lst)
(make-soft-port
(vector (lambda (c) #f) ; write char
(lambda (s) #f) ; write string
(lambda () #f) ; flush
(lambda () ; read char
(make-soft-port #:read-string
(lambda ()
(let ((c (car lst)))
(set! lst (cdr lst))
c))
(lambda () #f)) ; close
"rw"))
(if c (string c) "")))))
(define (call-with-port p proc)
(dynamic-wind
@ -1811,13 +1807,8 @@
(pass-if "Don't read from the port unless user asks to"
(let* ((p (make-soft-port
(vector
(lambda (c) #f) ; write char
(lambda (s) #f) ; write string
(lambda () #f) ; flush
(lambda () (throw 'fail)) ; read char
(lambda () #f))
"rw")))
#:write-string (lambda (str) #t)
#:read-string (lambda () (throw 'fail)))))
(set-port-encoding! p "UTF-16")
(display "abc" p)
(set-port-encoding! p "UTF-32")

55
test-suite/tests/r6rs-ports.test
View file

@ -1,6 +1,6 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2009-2012,2013-2015,2018-2021,2023,2024-2024 Free Software Foundation, Inc.
;;;; Copyright (C) 2009-2012,2013-2015,2018-2021,2023,2024-2025 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -23,6 +23,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 match)
#:use-module (ice-9 soft-ports)
#:use-module ((ice-9 binary-ports) #:select (get-bytevector-some!))
#:use-module (rnrs io ports)
#:use-module (rnrs io simple)
@ -56,17 +57,16 @@
(define (write-char chr)
(set! write-index (+ 1 write-index))
(maybe-fail write-index ENOSPC))
(define port
(make-soft-port
(vector write-char
(lambda (str) ;; write-string
#:write-string (lambda (str)
(for-each write-char (string->list str)))
(lambda () #t) ;; flush-output
(lambda () ;; read-char
#:read-string (lambda ()
(set! read-index (+ read-index 1))
(maybe-fail read-index EIO)
#\space)
(lambda () #t)) ;; close-port
"rw")))
" ")))
(setvbuf port 'none)
port))
(define (call-with-bytevector-output-port/transcoded transcoder receiver)
(call-with-bytevector-output-port
@ -206,26 +206,13 @@
(pass-if "get-bytevector-all"
(let* ((str "GNU Guile")
(index 0)
(port (make-soft-port
(vector #f #f #f
(port (make-soft-port #:read-string
(lambda ()
(if (>= index (string-length str))
(eof-object)
(if (< index (string-length str))
(let ((c (string-ref str index)))
(set! index (+ index 1))
c)))
(lambda () #t)
(let ((cont? #f))
(lambda ()
;; Number of readily available octets: falls to
;; zero after 4 octets have been read and then
;; starts again.
(let ((a (if cont?
(- (string-length str) index)
(- 4 (modulo index 5)))))
(if (= 0 a) (set! cont? #t))
a))))
"r"))
(string c))
""))))
(bv (get-bytevector-all port)))
(and (bytevector? bv)
(= index (string-length str))
@ -242,19 +229,19 @@
(bytevector-u8-set! bv write-index
(char->integer chr))
(set! write-index (+ 1 write-index)))))
(define port
(make-soft-port
(vector write-char
(lambda (str) ;; write-string
(for-each write-char (string->list str)))
(lambda () #t) ;; flush-output
(lambda () ;; read-char
#:write-string
(lambda (str) (for-each write-char (string->list str)))
#:read-string
(lambda ()
(if (>= read-index (bytevector-length bv))
(eof-object)
""
(let ((c (bytevector-u8-ref bv read-index)))
(set! read-index (+ read-index 1))
(integer->char c))))
(lambda () #t)) ;; close-port
"rw")))
(string (integer->char c)))))))
(setvbuf port 'none)
port))
(with-test-prefix "8.2.11 Binary Output"

18
test-suite/tests/web-client.test
View file

@ -1,6 +1,6 @@
;;;; web-client.test --- HTTP client -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2013 Free Software Foundation, Inc.
;;;; Copyright (C) 2013, 2025 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -23,6 +23,7 @@
#:use-module (web response)
#:use-module (ice-9 iconv)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 soft-ports)
#:use-module (test-suite lib))
@ -470,7 +471,7 @@ Connection: close\r
(unless writing?
(error "Port closed for writing"))
(put-u8 request-port (char->integer c)))
(define (put-string s)
(define (write-string s)
(string-for-each put-char s)
(set! writing? #f)
(set! reading? #t)
@ -485,23 +486,24 @@ Connection: close\r
(equal? (or actual-body #vu8())
(string->bytevector expected-request-body
request-body-encoding)))))
(define (get-char)
(define (read-string)
(unless reading?
(error "Port closed for reading"))
(let ((c (read-char response-port)))
(if (char? c)
c
(string c)
(let ((u8 (get-u8 response-body-port)))
(if (eof-object? u8)
u8
(integer->char u8))))))
""
(string (integer->char u8)))))))
(define (close)
(when writing?
(unless (eof-object? (get-u8 response-body-port))
(error "Failed to consume all of body"))))
(let ((soft-port (make-soft-port
(vector put-char put-string #f get-char close)
"rw")))
#:write-string write-string
#:read-string read-string
#:close close)))
;; Arrange it so that the only time our put-char/put-string
;; functions are called is during force-output.
(setvbuf soft-port 'block 10000)