Re: Making custom binary input ports unbuffered

[Ludovic Courtès]

So here’s a version that adds a ‘setvbuf’ method to scm_t_port_internal,
and uses that to implement CBIP buffering.  CBIPs remain fully buffered
by default (after more thoughts I considered that this conservative
approach was more reasonable and acceptable if documented.)

I’d like to commit to stable-2.0.  WDYT?

Thanks,
Ludo’.

>From 1c5cc0ad6938443e9dc5271b6974a2c8df3b1909 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Thu, 16 Jan 2014 23:52:01 +0100
Subject: [PATCH 1/2] Prepare 'setvbuf' to support for non-file ports.

* libguile/ports-internal.h (struct scm_port_internal): Add
  setvbuf' field.  Change 'pending_eof' to a 1-bit unsigned char.
* libguile/ports.c (scm_new_port_table_entry): Clear 'pti->setvbuf'.
* libguile/fports.c (scm_setvbuf): Accept any open port, and error out
  when PORT's setvbuf' field is NULL.  Remove explicit 'scm_gc_free' calls.
  (scm_i_fdes_to_port): Set PORT's 'setvbuf' field.
* test-suite/tests/ports.test ("setvbuf")["closed port", "string port"]:
  New tests.
* doc/ref/posix.texi (Ports and File Descriptors): Suggest that
  'setvbuf' works for different port types.
---
 doc/ref/posix.texi          |  3 +++
 libguile/fports.c           | 42 +++++++++++++++++++++++++++---------------
 libguile/ports-internal.h   | 14 ++++++++++++--
 libguile/ports.c            |  8 +++++++-
 test-suite/tests/ports.test | 14 +++++++++++++-
 5 files changed, 62 insertions(+), 19 deletions(-)

diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index b3a6a04..56f5c78 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -470,6 +470,9 @@ line buffered
 block buffered, using a newly allocated buffer of @var{size} bytes.
 If @var{size} is omitted, a default size will be used.
 @end defvar
+
+Only certain types of ports are supported, most importantly
+file ports.
 @end deffn
 
 @deffn {Scheme Procedure} fcntl port/fd cmd [value]
diff --git a/libguile/fports.c b/libguile/fports.c
index 70732e5..365d3ff 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,5 +1,6 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- *   2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software 
Foundation, Inc.
+ *   2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
+ *   2014 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 License
@@ -58,6 +59,7 @@
 #include "libguile/hashtab.h"
 
 #include "libguile/fports.h"
+#include "libguile/ports-internal.h"
 
 #if SIZEOF_OFF_T == SIZEOF_INT
 #define OFF_T_MAX  INT_MAX
@@ -78,10 +80,10 @@ scm_t_bits scm_tc16_fport;
 /* default buffer size, used if the O/S won't supply a value.  */
 static const size_t default_buffer_size = 1024;
 
-/* create FPORT buffer with specified sizes (or -1 to use default size or
-   0 for no buffer.  */
+/* Create FPORT buffers with specified sizes (or -1 to use default size
+   or 0 for no buffer.)  */
 static void
-scm_fport_buffer_add (SCM port, long read_size, int write_size)
+scm_fport_buffer_add (SCM port, long read_size, long write_size)
 #define FUNC_NAME "scm_fport_buffer_add"
 {
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -147,7 +149,9 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
            "@item _IOFBF\n"
            "block buffered, using a newly allocated buffer of @var{size} 
bytes.\n"
            "If @var{size} is omitted, a default size will be used.\n"
-           "@end table")
+           "@end table\n\n"
+           "Only certain types of ports are supported, most importantly\n"
+           "file ports.")
 #define FUNC_NAME s_scm_setvbuf
 {
   int cmode;
@@ -155,10 +159,17 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
   size_t ndrained;
   char *drained;
   scm_t_port *pt;
+  scm_t_port_internal *pti;
 
   port = SCM_COERCE_OUTPORT (port);
 
-  SCM_VALIDATE_OPFPORT (1,port);
+  SCM_VALIDATE_OPENPORT (1, port);
+  pti = SCM_PORT_GET_INTERNAL (port);
+
+  if (pti->setvbuf == NULL)
+    scm_wrong_type_arg_msg (FUNC_NAME, 1, port,
+                           "port that supports 'setvbuf'");
+
   cmode = scm_to_int (mode);
   if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
     scm_out_of_range (FUNC_NAME, mode);
@@ -169,9 +180,8 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
       cmode = _IOFBF;
     }
   else
-    {
-      SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & 
~(scm_t_bits)SCM_BUFLINE);
-    }
+    SCM_SET_CELL_WORD_0 (port,
+                        SCM_CELL_WORD_0 (port) & ~(scm_t_bits) SCM_BUFLINE);
 
   if (SCM_UNBNDP (size))
     {
@@ -216,12 +226,8 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
       pt->read_end = pt->saved_read_end;
       pt->read_buf_size = pt->saved_read_buf_size;
     }
-  if (pt->read_buf != &pt->shortbuf)
-    scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
-  if (pt->write_buf != &pt->shortbuf)
-    scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
 
-  scm_fport_buffer_add (port, csize, csize);
+  pti->setvbuf (port, csize, csize);
 
   if (ndrained > 0)
     /* Put DRAINED back to PORT.  */
@@ -542,6 +548,7 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
 {
   SCM port;
   scm_t_port *pt;
+  scm_t_port_internal *pti;
 
   /* Test that fdes is valid.  */
 #ifdef F_GETFL
@@ -567,7 +574,12 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
 
   port = scm_new_port_table_entry (scm_tc16_fport);
   SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
-  pt = SCM_PTAB_ENTRY(port);
+  pt = SCM_PTAB_ENTRY (port);
+
+  /* File ports support 'setvbuf'.  */
+  pti = SCM_PORT_GET_INTERNAL (port);
+  pti->setvbuf = scm_fport_buffer_add;
+
   {
     scm_t_fport *fp
       = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h
index 8a3a00b..48dcaa7 100644
--- a/libguile/ports-internal.h
+++ b/libguile/ports-internal.h
@@ -1,7 +1,7 @@
 /*
  * ports-internal.h - internal-only declarations for ports.
  *
- * Copyright (C) 2013 Free Software Foundation, Inc.
+ * Copyright (C) 2013, 2014 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 License
@@ -50,7 +50,17 @@ struct scm_port_internal
   unsigned at_stream_start_for_bom_write : 1;
   scm_t_port_encoding_mode encoding_mode;
   scm_t_iconv_descriptors *iconv_descriptors;
-  int pending_eof;
+  unsigned char pending_eof: 1;
+
+  /* When non-NULL, this is the method called by 'setvbuf' for this port.
+     It must create read and write buffers for PORT with the specified
+     sizes (a size of 0 is for unbuffered ports, which should use the
+     'shortbuf' field.)  Size -1 means to use the port's preferred buffer
+     size.  */
+  /* XXX: In 2.2 make this a property of the 'scm_t_ptob_descriptor'.  */
+  void (*setvbuf) (SCM port, long read_size, long write_size);
+
+  /* Key-value properties.  */
   SCM alist;
 };
 
diff --git a/libguile/ports.c b/libguile/ports.c
index 4516160..4f401de 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
- *   2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 License
@@ -677,6 +677,12 @@ scm_new_port_table_entry (scm_t_bits tag)
   pti->pending_eof = 0;
   pti->alist = SCM_EOL;
 
+  /* Until Guile 2.0.9 included, 'setvbuf' would only work on file
+     ports.  Now all port types can be supported, but it's not clear
+     that port types out in wild accept having someone else fiddle with
+     their buffer.  Thus, conservatively turn it off by default.  */
+  pti->setvbuf = NULL;
+
   SCM_SET_CELL_TYPE (z, tag);
   SCM_SETPTAB_ENTRY (z, entry);
 
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 9b1c6c0..c2f4480 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -2,7 +2,7 @@
 ;;;; Jim Blandy <address@hidden> --- May 1999
 ;;;;
 ;;;;   Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
-;;;;      2011, 2012, 2013 Free Software Foundation, Inc.
+;;;;      2011, 2012, 2013, 2014 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
@@ -1499,6 +1499,18 @@
 
 (with-test-prefix "setvbuf"
 
+  (pass-if-exception "closed port"
+      exception:wrong-type-arg
+    (let ((port (open-input-file "/dev/null")))
+      (close-port port)
+      (setvbuf port _IOFBF)))
+
+  (pass-if-exception "string port"
+      exception:wrong-type-arg
+    (let ((port (open-input-string "Hey!")))
+      (close-port port)
+      (setvbuf port _IOFBF)))
+
   (pass-if "line/column number preserved"
     ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
     ;; line and/or column number.
-- 
1.8.4

>From 0fd3ab580b0bf71cf5133744f1b60499c23bbcb6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Thu, 16 Jan 2014 23:43:31 +0100
Subject: [PATCH 2/2] Custom binary input ports support 'setvbuf'.

* libguile/r6rs-ports.c (CBIP_BUFFER_SIZE): Adjust comment.  Set to 8KiB.
  (SCM_SET_CBIP_BYTEVECTOR): New macro.
  (cbip_setvbuf): New function.
  (make_cbip): Set PORT's 'setvbuf' internal field.
  (cbip_fill_input): Check whether PORT is buffered.  When unbuffered,
  check whether BV can hold C_REQUESTED bytes, and allocate a new
  bytevector if not; copy the data back from BV to c_port->read_pos.
  Remove 'again' label, and don't loop there.
* test-suite/tests/r6rs-ports.test ("7.2.7 Input Ports")["custom binary
  input port unbuffered & 'port-position'", "custom binary input port
  unbuffered & 'read!' calls", "custom binary input port, unbuffered
  then buffered", "custom binary input port, buffered then unbuffered"]:
  New tests.
* doc/ref/api-io.texi (R6RS Binary Input): Document the buffering of
  custom binary input ports, and link to 'setvbuf'.
---
 doc/ref/api-io.texi              |   4 ++
 libguile/r6rs-ports.c            |  94 +++++++++++++++++++++++++-----
 test-suite/tests/r6rs-ports.test | 123 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 205 insertions(+), 16 deletions(-)

diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index f1170eb..02d92a2 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1816,6 +1816,10 @@ indicating the position of the next byte is to read.
 Finally, if @var{close} is not @code{#f}, it must be a thunk.  It is
 invoked when the custom binary input port is closed.
 
+The returned port is fully buffered by default, but its buffering mode
+can be changed using @code{setvbuf} (@pxref{Ports and File Descriptors,
address@hidden).
+
 Using a custom binary input port, the @code{open-bytevector-input-port}
 procedure could be implemented as follows:
 
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 0b1d162..30456a8 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -37,6 +37,7 @@
 #include "libguile/validate.h"
 #include "libguile/values.h"
 #include "libguile/vectors.h"
+#include "libguile/ports-internal.h"
 
 

@@ -280,18 +281,59 @@ cbp_close (SCM port)
 
 static scm_t_bits custom_binary_input_port_type = 0;
 
-/* Size of the buffer embedded in custom binary input ports.  */
-#define CBIP_BUFFER_SIZE  4096
+/* Initial size of the buffer embedded in custom binary input ports.  */
+#define CBIP_BUFFER_SIZE  8192
 
 /* Return the bytevector associated with PORT.  */
 #define SCM_CBIP_BYTEVECTOR(_port)                             \
   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
 
+/* Set BV as the bytevector associated with PORT.  */
+#define SCM_SET_CBIP_BYTEVECTOR(_port, _bv)                            \
+  SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv))
+
 /* Return the various procedures of PORT.  */
 #define SCM_CBIP_READ_PROC(_port)                              \
   SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
 
 
+/* Set PORT's internal buffer according to READ_SIZE.  */
+static void
+cbip_setvbuf (SCM port, long read_size, long write_size)
+{
+  SCM bv;
+  scm_t_port *pt;
+
+  pt = SCM_PTAB_ENTRY (port);
+  bv = SCM_CBIP_BYTEVECTOR (port);
+
+  switch (read_size)
+    {
+    case 0:
+      /* Unbuffered: keep PORT's bytevector as is (it will be used in
+        future 'scm_c_read' calls), but point to the one-byte buffer.  */
+      pt->read_buf = &pt->shortbuf;
+      pt->read_buf_size = 1;
+      break;
+
+    case -1:
+      /* Preferred size: keep the current bytevector and use it as the
+        backing store.  */
+      pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+      pt->read_buf_size = SCM_BYTEVECTOR_LENGTH (bv);
+      break;
+
+    default:
+      /* Fully buffered: allocate a buffer of READ_SIZE bytes.  */
+      bv = scm_c_make_bytevector (read_size);
+      SCM_SET_CBIP_BYTEVECTOR (port, bv);
+      pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+      pt->read_buf_size = read_size;
+    }
+
+  pt->read_pos = pt->read_end = pt->read_buf;
+}
+
 static inline SCM
 make_cbip (SCM read_proc, SCM get_position_proc,
           SCM set_position_proc, SCM close_proc)
@@ -331,7 +373,10 @@ make_cbip (SCM read_proc, SCM get_position_proc,
   c_port->read_end = (unsigned char *) c_bv;
   c_port->read_buf_size = c_len;
 
-  /* Mark PORT as open, readable and unbuffered (hmm, how elegant...).  */
+  /* 'setvbuf' is supported.  */
+  SCM_PORT_GET_INTERNAL (port)->setvbuf = cbip_setvbuf;
+
+  /* Mark PORT as open and readable.  */
   SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
 
   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
@@ -346,26 +391,39 @@ cbip_fill_input (SCM port)
   int result;
   scm_t_port *c_port = SCM_PTAB_ENTRY (port);
 
- again:
   if (c_port->read_pos >= c_port->read_end)
     {
       /* Invoke the user's `read!' procedure.  */
+      int buffered;
       size_t c_octets, c_requested;
       SCM bv, read_proc, octets;
 
       c_requested = c_port->read_buf_size;
+      read_proc = SCM_CBIP_READ_PROC (port);
 
-      /* Use the bytevector associated with PORT as the buffer passed to the
-        `read!' procedure, thereby avoiding additional allocations.  */
       bv = SCM_CBIP_BYTEVECTOR (port);
-      read_proc = SCM_CBIP_READ_PROC (port);
+      buffered =
+       (c_port->read_buf == (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
 
-      /* The assumption here is that C_PORT's internal buffer wasn't changed
-        behind our back.  */
-      assert (c_port->read_buf ==
-             (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
-      assert ((unsigned) c_port->read_buf_size
-             == SCM_BYTEVECTOR_LENGTH (bv));
+      if (buffered)
+       /* Make sure the buffer isn't corrupt.  BV can be passed directly
+          to READ_PROC.  */
+       assert (c_port->read_buf_size == SCM_BYTEVECTOR_LENGTH (bv));
+      else
+       {
+         /* This is an unbuffered port.  When called via the
+            'get-bytevector-*' procedures, and thus via 'scm_c_read', we
+            are passed the caller-provided buffer, so we need to check its
+            size.  */
+         if (SCM_BYTEVECTOR_LENGTH (bv) < c_requested)
+           {
+             /* Bad luck: we have to make another allocation.  Save that
+                bytevector for later reuse, in the hope that the application
+                has regular access patterns.  */
+             bv = scm_c_make_bytevector (c_requested);
+             SCM_SET_CBIP_BYTEVECTOR (port, bv);
+           }
+       }
 
       octets = scm_call_3 (read_proc, bv, SCM_INUM0,
                           scm_from_size_t (c_requested));
@@ -373,11 +431,15 @@ cbip_fill_input (SCM port)
       if (SCM_UNLIKELY (c_octets > c_requested))
        scm_out_of_range (FUNC_NAME, octets);
 
-      c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+      if (!buffered)
+       /* Copy the data back to the internal buffer.  */
+       memcpy ((char *) c_port->read_pos, SCM_BYTEVECTOR_CONTENTS (bv),
+               c_octets);
+
       c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
 
-      if (c_octets > 0)
-       goto again;
+      if (c_octets != 0 || c_requested == 0)
+       result = (int) *c_port->read_pos;
       else
        result = EOF;
     }
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 2b62bed..213c8b7 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -456,6 +456,129 @@ not `set-port-position!'"
                          (u8-list->bytevector
                           (map char->integer (string->list "Port!")))))))
 
+  (pass-if-equal "custom binary input port unbuffered & 'port-position'"
+      '(0 2 5 11)
+    ;; Check that the value returned by 'port-position' is correct, and
+    ;; that each 'port-position' call leads one call to the
+    ;; 'get-position' method.
+    (let* ((str    "Hello Port!")
+           (output (make-bytevector (string-length str)))
+           (source (with-fluids ((%default-port-encoding "UTF-8"))
+                     (open-string-input-port str)))
+           (read!  (lambda (bv start count)
+                     (let ((r (get-bytevector-n! source bv start count)))
+                       (if (eof-object? r)
+                           0
+                           r))))
+           (pos     '())
+           (get-pos (lambda ()
+                      (let ((p (port-position source)))
+                        (set! pos (cons p pos))
+                        p)))
+           (port    (make-custom-binary-input-port "the port" read!
+                                                   get-pos #f #f)))
+      (setvbuf port _IONBF)
+      (and (= 0 (port-position port))
+           (begin
+             (get-bytevector-n! port output 0 2)
+             (= 2 (port-position port)))
+           (begin
+             (get-bytevector-n! port output 2 3)
+             (= 5 (port-position port)))
+           (let ((bv (string->utf8 (get-string-all port))))
+             (bytevector-copy! bv 0 output 5 (bytevector-length bv))
+             (= (string-length str) (port-position port)))
+           (bytevector=? output (string->utf8 str))
+           (reverse pos))))
+
+  (pass-if-equal "custom binary input port unbuffered & 'read!' calls"
+      `((2 "He") (3 "llo") (42 " Port!"))
+    (let* ((str    "Hello Port!")
+           (source (with-fluids ((%default-port-encoding "UTF-8"))
+                     (open-string-input-port str)))
+           (reads  '())
+           (read!  (lambda (bv start count)
+                     (set! reads (cons count reads))
+                     (let ((r (get-bytevector-n! source bv start count)))
+                       (if (eof-object? r)
+                           0
+                           r))))
+           (port   (make-custom-binary-input-port "the port" read!
+                                                  #f #f #f)))
+
+      (setvbuf port _IONBF)
+      (let ((ret (list (get-bytevector-n port 2)
+                       (get-bytevector-n port 3)
+                       (get-bytevector-n port 42))))
+        (zip (reverse reads)
+             (map (lambda (obj)
+                    (if (bytevector? obj)
+                        (utf8->string obj)
+                        obj))
+                  ret)))))
+
+  (pass-if-equal "custom binary input port, unbuffered then buffered"
+      `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
+        (777 ,(eof-object)))
+    (let* ((str    "Lorem ipsum dolor sit amet, consectetur…")
+           (source (with-fluids ((%default-port-encoding "UTF-8"))
+                     (open-string-input-port str)))
+           (reads  '())
+           (read!  (lambda (bv start count)
+                     (set! reads (cons count reads))
+                     (let ((r (get-bytevector-n! source bv start count)))
+                       (if (eof-object? r)
+                           0
+                           r))))
+           (port   (make-custom-binary-input-port "the port" read!
+                                                  #f #f #f)))
+
+      (setvbuf port _IONBF)
+      (let ((ret (list (get-bytevector-n port 6)
+                       (get-bytevector-n port 12)
+                       (begin
+                         (setvbuf port _IOFBF 777)
+                         (get-bytevector-n port 42))
+                       (get-bytevector-n port 42))))
+        (zip (reverse reads)
+             (map (lambda (obj)
+                    (if (bytevector? obj)
+                        (utf8->string obj)
+                        obj))
+                  ret)))))
+
+  (pass-if-equal "custom binary input port, buffered then unbuffered"
+      `((18
+         42 14             ; scm_c_read tries to fill the 42-byte buffer
+         42)
+        ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
+    (let* ((str    "Lorem ipsum dolor sit amet, consectetur bla…")
+           (source (with-fluids ((%default-port-encoding "UTF-8"))
+                     (open-string-input-port str)))
+           (reads  '())
+           (read!  (lambda (bv start count)
+                     (set! reads (cons count reads))
+                     (let ((r (get-bytevector-n! source bv start count)))
+                       (if (eof-object? r)
+                           0
+                           r))))
+           (port   (make-custom-binary-input-port "the port" read!
+                                                  #f #f #f)))
+
+      (setvbuf port _IOFBF 18)
+      (let ((ret (list (get-bytevector-n port 6)
+                       (get-bytevector-n port 12)
+                       (begin
+                         (setvbuf port _IONBF)
+                         (get-bytevector-n port 42))
+                       (get-bytevector-n port 42))))
+        (list (reverse reads)
+              (map (lambda (obj)
+                     (if (bytevector? obj)
+                         (utf8->string obj)
+                         obj))
+                   ret)))))
+
   (pass-if "custom binary input port `close-proc' is called"
     (let* ((closed?  #f)
            (read!    (lambda (bv start count) 0))
-- 
1.8.4