From 1da66a6ab14b6aaedeea2a77dce130c8b397cbf0 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 1 Mar 2017 14:14:06 +0100
Subject: [PATCH] String ports can be truncated

* libguile/strports.c (string_port_truncate):
  (scm_make_string_port_type): Support truncate-file on string ports.
* test-suite/tests/ports.test ("string ports"): Add tests.
---
 libguile/strports.c         | 13 +++++++++++++
 test-suite/tests/ports.test | 39 +++++++++++++++++++++++++++++++++++++
 2 files changed, 52 insertions(+)

diff --git a/libguile/strports.c b/libguile/strports.c
index b12d6694a..5f78785d1 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -134,6 +134,18 @@ string_port_seek (SCM port, scm_t_off offset, int whence)
 }
 #undef FUNC_NAME
 
+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 (0 <= length && stream->pos <= length && length <= stream->len)
+    stream->len = length;
+  else
+    scm_out_of_range (FUNC_NAME, scm_from_off_t_or_off64_t (length));
+}
+#undef FUNC_NAME
 
 
 /* The initial size in bytes of a string port's buffer.  */
@@ -372,6 +384,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/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 86165fdef..207c0cfa7 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -735,6 +735,45 @@
     (pass-if "output check"
              (string=? text result)))
 
+  (pass-if-exception "truncating input string fails"
+      exception:wrong-type-arg
+    (call-with-input-string "hej"
+      (lambda (p)
+        (truncate-file p 0))))
+
+  (pass-if-equal "truncating output string" "hej"
+    (call-with-output-string
+      (lambda (p)
+        (truncate-file p 0)
+        (display "hej" p))))
+
+  (pass-if-exception "truncating output string before position"
+      exception:out-of-range
+    (call-with-output-string
+      (lambda (p)
+        (display "hej" p)
+        (truncate-file p 0))))
+
+  (pass-if-equal "truncating output string at position" "hej"
+    (call-with-output-string
+      (lambda (p)
+        (display "hej" p)
+        (truncate-file p 3))))
+
+  (pass-if-equal "truncating output string after seek" ""
+    (call-with-output-string
+      (lambda (p)
+        (display "hej" p)
+        (seek p 0 SEEK_SET)
+        (truncate-file p 0))))
+
+  (pass-if-equal "truncating output string after seek to end" "hej"
+    (call-with-output-string
+      (lambda (p)
+        (display "hej" p)
+        (seek p 0 SEEK_SET)
+        (truncate-file p 3))))
+
   (pass-if "%default-port-encoding is ignored"
     (let ((str "ĉu bone?"))
       ;; Latin-1 cannot represent ‘ĉ’.