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.

diff --git a/libguile/strports.c b/libguile/strports.c
index b12d6694acd1bd32344d98aaf86285d97ec2d2d5..5f78785d1923b52b453aed43fc8ba87dbb7faf36 100644 (file)
--- 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
 
 \f
 /* 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 86165fdef986be63d16f0768d8612b534aa4716f..207c0cfa71d84939475af15f4f23ed292dd58ee7 100644 (file)
--- 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 ‘ĉ’.