Custom binary input ports sanity-check the return value of 'read!'.

* libguile/r6rs-ports.c (cbip_fill_input): Throw an exception when
  C_OCTETS is greater than what was requested.
* test-suite/tests/r6rs-ports.test ("7.2.7 Input Ports")["custom binary
  input port 'read!' returns too much"]: New test.

2 files changed, 16 insertions, 3 deletions

diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 790c24cce..0b1d1628e 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -350,9 +350,11 @@ cbip_fill_input (SCM port)
   if (c_port->read_pos >= c_port->read_end)
     {
       /* Invoke the user's `read!' procedure.  */
-      unsigned c_octets;
+      size_t c_octets, c_requested;
       SCM bv, read_proc, octets;
 
+      c_requested = c_port->read_buf_size;
+
       /* Use the bytevector associated with PORT as the buffer passed to the
 	 `read!' procedure, thereby avoiding additional allocations.  */
       bv = SCM_CBIP_BYTEVECTOR (port);
@@ -366,8 +368,10 @@ cbip_fill_input (SCM port)
 	      == SCM_BYTEVECTOR_LENGTH (bv));
 
       octets = scm_call_3 (read_proc, bv, SCM_INUM0,
-			   SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
-      c_octets = scm_to_uint (octets);
+			   scm_from_size_t (c_requested));
+      c_octets = scm_to_size_t (octets);
+      if (SCM_UNLIKELY (c_octets > c_requested))
+	scm_out_of_range (FUNC_NAME, octets);
 
       c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
       c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index eaae29fdc..2b62bedbf 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -411,6 +411,15 @@
       (not (or (port-has-port-position? port)
                (port-has-set-port-position!? port)))))
 
+  (pass-if-exception "custom binary input port 'read!' returns too much"
+      exception:out-of-range
+    ;; In Guile <= 2.0.9 this would segfault.
+    (let* ((read! (lambda (bv start count)
+                    (+ count 4242)))
+           (port (make-custom-binary-input-port "the port" read!
+                                                #f #f #f)))
+      (get-bytevector-all port)))
+
   (pass-if-equal "custom binary input port supports `port-position', \
 not `set-port-position!'"
       42