[PATCH] Fix bug #24816: open-string-output-port extraction thunk does not truncate string port as expected by R6RS in Guile 2.1.7

[Freja Nordsiek <fnordsie@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 737 bytes --]

Patch for bug #24816: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=24816

Patch is for Guile 2.1.7.1 (problem dates back at least as far as 2.1.4).

Problem is that the extraction thunk returned by
open-string-output-port in module "rnrs io ports" does not truncate
the string port as expected by R6RS (page 39 of the library standard
document).

The open-string-output-port procedure (module/rnrs/io/ports.scm) is
changed to make the extraction thunk call truncate-file on the string
port after extracting its contents. In order to make that work, string
ports were made truncatable (libguile/strports.c). A test
(test-suite/tests/r6rs-ports.scm) was added to make sure that the
string port is truncated by the thunk.


Freja Nordsiek

[-- Attachment #2: 0001-Fixed-bug-where-string-reading-thunk-provided-by-R6R.patch --]
[-- Type: text/x-patch, Size: 4015 bytes --]

From b564efebd5268f393fa2704587eed530aff14cb5 Mon Sep 17 00:00:00 2001
From: Freja Nordsiek <fnordsie@gmail.com>
Date: Tue, 21 Feb 2017 20:21:06 +0100
Subject: [PATCH] Fixed bug where string reading thunk provided by R6RS
 open-string-output-port does not truncate the string port.

---
 libguile/strports.c              | 23 +++++++++++++++++++++++
 module/rnrs/io/ports.scm         |  7 +++++--
 test-suite/tests/r6rs-ports.test | 16 ++++++++++++++++
 3 files changed, 44 insertions(+), 2 deletions(-)

diff --git a/libguile/strports.c b/libguile/strports.c
index b12d669..5f9519d 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -139,6 +139,28 @@ string_port_seek (SCM port, scm_t_off offset, int whence)
 /* The initial size in bytes of a string port's buffer.  */
 #define INITIAL_BUFFER_SIZE 128
 
+
+static void
+string_port_truncate (SCM port, scm_t_off length)
+#define FUNC_NAME "string_port_truncate"
+{
+  struct string_port *stream = (void *) SCM_STREAM (port);
+
+  if (length < 0)
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `length' parameter");
+  else if (length >= stream->len)
+    return;
+
+  /* Allocate a new buffer to write to.  */
+  stream->bytevector = scm_c_make_bytevector (max (INITIAL_BUFFER_SIZE, length));
+
+  stream->len = length;
+  stream->pos = min (stream->pos, length);
+}
+#undef FUNC_NAME
+
+
+
 /* Return a new string port with MODES.  If STR is #f, a new backing
    buffer is allocated; otherwise STR must be a string and a copy of it
    serves as the buffer for the new port.  */
@@ -372,6 +394,7 @@ scm_make_string_port_type ()
                                               string_port_read,
                                               string_port_write);
   scm_set_port_seek (ptob, string_port_seek);
+  scm_set_port_truncate (ptob, string_port_truncate);
 
   return ptob;
 }
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index e924ad8..5d1b145 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -384,10 +384,13 @@ read from/written to in @var{port}."
 
 (define (open-string-output-port)
   "Return two values: an output port that will collect characters written to it
-as a string, and a thunk to retrieve the characters associated with that port."
+as a string, and a thunk to retrieve the characters associated with that port
+and then truncates the string port."
   (let ((port (open-output-string)))
     (values port
-            (lambda () (get-output-string port)))))
+            (lambda () (let ((out (get-output-string port)))
+                         (truncate-file port 0)
+                         out)))))
 
 (define* (open-file-output-port filename
                                 #:optional
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 94d9fc0..3ab79bc 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -809,6 +809,22 @@ not `set-port-position!'"
              (bytevector=? (get-content) source)
              (bytevector=? (get-content) (make-bytevector 0))))))
 
+  (pass-if "open-string-output-port write and truncated readback"
+    (let-values (((port get-content)
+                  (open-string-output-port)))
+      (let ((source "Hello Port!"))
+        (put-string port source)
+        (let* ((read-gos-before1 (get-output-string port))
+               (read-gos-before2 (get-output-string port))
+               (read-provided1 (get-content))
+               (read-gos-after (get-output-string port))
+               (read-provided2 (get-content)))
+          (and (string=? source read-gos-before1)
+               (string=? source read-gos-before2)
+               (string=? source read-provided1)
+               (string-null? read-gos-after)
+               (string-null? read-provided2))))))
+
   (pass-if "make-custom-binary-output-port"
     (let ((port (make-custom-binary-output-port "cbop"
                                                 (lambda (x y z) 0)
-- 
2.7.4