diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 82881aa28..651007e97 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -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 - (let ((c (car lst))) - (set! lst (cdr lst)) - c)) - (lambda () #f)) ; close - "rw")) + (make-soft-port #:read-string + (lambda () + (let ((c (car lst))) + (set! lst (cdr lst)) + (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") diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index c782b65f3..7332388c0 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -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)) - (make-soft-port - (vector write-char - (lambda (str) ;; write-string - (for-each write-char (string->list str))) - (lambda () #t) ;; flush-output - (lambda () ;; read-char - (set! read-index (+ read-index 1)) - (maybe-fail read-index EIO) - #\space) - (lambda () #t)) ;; close-port - "rw"))) + (define port + (make-soft-port + #:write-string (lambda (str) + (for-each write-char (string->list str))) + #:read-string (lambda () + (set! read-index (+ read-index 1)) + (maybe-fail read-index EIO) + " "))) + (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 - (lambda () - (if (>= index (string-length str)) - (eof-object) - (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")) + (port (make-soft-port #:read-string + (lambda () + (if (< index (string-length str)) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + (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))))) - (make-soft-port - (vector write-char - (lambda (str) ;; write-string - (for-each write-char (string->list str))) - (lambda () #t) ;; flush-output - (lambda () ;; read-char - (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"))) + (define port + (make-soft-port + #:write-string + (lambda (str) (for-each write-char (string->list str))) + #:read-string + (lambda () + (if (>= read-index (bytevector-length bv)) + "" + (let ((c (bytevector-u8-ref bv read-index))) + (set! read-index (+ read-index 1)) + (string (integer->char c))))))) + (setvbuf port 'none) + port)) (with-test-prefix "8.2.11 Binary Output" diff --git a/test-suite/tests/web-client.test b/test-suite/tests/web-client.test index 805baa9e9..d9178964b 100644 --- a/test-suite/tests/web-client.test +++ b/test-suite/tests/web-client.test @@ -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)