Fix read-bytevector argument count in make-delimited-input-port2.0.1

Similar to the 7c9edbf change in intarweb 3.0.1:

In CHICKEN 6.0.0, the signature was documented to be different, but
we were using the actual signature.  For later CHICKEN versions, the
signature was updated to match the documentation so now we're kind of
stuck having to support both signatures.

Since we cannot cond-expand our way out of this because there are no
features that differ between 6.0.0 and 6.0.1, we'll have to use
case-lambda and convert the old signature to the new one.  Oh well...

2 files changed, 85 insertions, 73 deletions

diff --git a/http-client.scm b/http-client.scm
index e6c8831..2d5e182 100644
--- a/http-client.scm
+++ b/http-client.scm
@@ -46,7 +46,7 @@
      server-connector default-server-connector
      prepare-request default-prepare-request)
 
-(import scheme (scheme base)
+(import scheme (scheme base) (scheme case-lambda)
         srfi-1 srfi-13 srfi-18 srfi-69
         (chicken base) (chicken string) (chicken time)
         (chicken sort) (chicken io) (chicken file posix) (chicken format)
@@ -283,6 +283,18 @@
   (if (not len)
       port ;; no need to delimit anything
       (let ((pos 0))
+        ;; NOTE: This is using case-lambda because the signature changed between CHICKEN 6.0.0 and later releases
+        ;; In 6.0.0 it receives the port and the the number of bytes to read so we have to convert that old
+        ;; signature to the newer signature.
+        (define read-bytevector/pos
+          (case-lambda
+           ((p bytes buf off)
+            (read-bytevector/pos buf off (+ bytes off)))
+           ((buf start end)
+            (let* ((bytes (min (- end start) (- len pos)))
+                   (bytes-read (read-bytevector! buf port start (+ start bytes))))
+              (set! pos (+ pos bytes-read))
+              bytes-read))))
         (make-input-port
          (lambda ()                     ; read-char
            (if (= pos len)
@@ -298,11 +310,7 @@
                       (if (= pos len)
                           #!eof
                           (peek-char port)))
-         read-bytevector: (lambda (p bytes buf off)
-                            (let* ((bytes (min bytes (- len pos)))
-                                   (bytes-read (read-bytevector! buf port off (+ off bytes))))
-                              (set! pos (+ pos bytes-read))
-                              bytes-read))
+         read-bytevector: read-bytevector/pos
          read-line: (lambda (p limit)
                       (if (= pos len)
                           #!eof
diff --git a/tests/run.scm b/tests/run.scm
index 9ad7fd8..0308bcc 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -303,38 +303,40 @@
             expected-data (log-body log))))
 
   (test-group "alist form data body with custom port"
-    (let* ((string-port (open-input-string "the file's contents"))
-           (custom-port (make-input-port (lambda () (read-char string-port))
-                                         (constantly #t)
-                                         (lambda () (close-input-port string-port))
-                                         read-bytevector: (lambda (p bytes buf off) (read-bytevector! buf string-port off bytes))))
-           (log (with-server-response
-                 (lambda ()
-                   (with-input-from-request
-                    "http://example.com"
-                    `((lala . "testing")
-                      (the-file file: ,custom-port
-                                filename: "str")
-                      ("more" . stuff))
-                    read-string))
-                 "HTTP/1.0 200 OK\r\n\r\n"))
-           (req (log-request log))
-           (h (request-headers req))
-           (boundary (header-param 'boundary 'content-type h))
-           (expected-data
-            (conc
-             "--" boundary "\r\n"
-             "Content-Disposition: form-data; name=\"lala\"\r\n\r\n"
-             "testing\r\n"
-             "--" boundary "\r\n"
-             "Content-Disposition: form-data; name=\"the-file\"; "
-             "filename=\"str\"\r\n"
-             "Content-Type: application/octet-stream\r\n\r\n"
-             "the file's contents\r\n"
-             "--" boundary "\r\n"
-             "Content-Disposition: form-data; name=\"more\"\r\n\r\n"
-             "stuff\r\n"
-             "--" boundary "--\r\n")))
+    (letrec* ((string-port (open-input-string "the file's contents"))
+              (read-bv-from-sp (case-lambda ((p bytes buf off) (read-bv-from-sp buf off (+ bytes off)))
+                                            ((buf start end) (read-bytevector! buf string-port start end))))
+              (custom-port (make-input-port (lambda () (read-char string-port))
+                                            (constantly #t)
+                                            (lambda () (close-input-port string-port))
+                                            read-bytevector: read-bv-from-sp))
+              (log (with-server-response
+                    (lambda ()
+                      (with-input-from-request
+                       "http://example.com"
+                       `((lala . "testing")
+                         (the-file file: ,custom-port
+                                   filename: "str")
+                         ("more" . stuff))
+                       read-string))
+                    "HTTP/1.0 200 OK\r\n\r\n"))
+              (req (log-request log))
+              (h (request-headers req))
+              (boundary (header-param 'boundary 'content-type h))
+              (expected-data
+               (conc
+                "--" boundary "\r\n"
+                "Content-Disposition: form-data; name=\"lala\"\r\n\r\n"
+                "testing\r\n"
+                "--" boundary "\r\n"
+                "Content-Disposition: form-data; name=\"the-file\"; "
+                "filename=\"str\"\r\n"
+                "Content-Type: application/octet-stream\r\n\r\n"
+                "the file's contents\r\n"
+                "--" boundary "\r\n"
+                "Content-Disposition: form-data; name=\"more\"\r\n\r\n"
+                "stuff\r\n"
+                "--" boundary "--\r\n")))
 
       (test "Request method" 'POST (request-method req))
       (test "Content type is multipart"
@@ -352,41 +354,43 @@
             expected-data (log-body log))))
 
   (test-group "alist form data body with custom port using HTTP/1.0"
-    (let* ((string-port (open-input-string "the file's contents"))
-           (custom-port (make-input-port (lambda () (read-char string-port))
-                                         (constantly #t)
-                                         (lambda () (close-input-port string-port))
-                                         read-bytevector: (lambda (p bytes buf off) (read-bytevector! buf string-port off bytes))))
-           (uri (uri-reference "http://example.com"))
-           (req (make-request uri: uri method: 'POST
-                              major: 1 minor: 0))
-           (log (with-server-response
-                 (lambda ()
-                   (with-input-from-request
-                    req
-                    `((lala . "testing")
-                      (the-file file: ,custom-port
-                                filename: "str")
-                      ("more" . stuff))
-                    read-string))
-                 "HTTP/1.0 200 OK\r\n\r\n"))
-           (req (log-request log))
-           (h (request-headers req))
-           (boundary (header-param 'boundary 'content-type h))
-           (expected-data
-            (conc
-             "--" boundary "\r\n"
-             "Content-Disposition: form-data; name=\"lala\"\r\n\r\n"
-             "testing\r\n"
-             "--" boundary "\r\n"
-             "Content-Disposition: form-data; name=\"the-file\"; "
-             "filename=\"str\"\r\n"
-             "Content-Type: application/octet-stream\r\n\r\n"
-             "the file's contents\r\n"
-             "--" boundary "\r\n"
-             "Content-Disposition: form-data; name=\"more\"\r\n\r\n"
-             "stuff\r\n"
-             "--" boundary "--\r\n")))
+    (letrec* ((string-port (open-input-string "the file's contents"))
+              (read-bv-from-sp (case-lambda ((p bytes buf off) (read-bv-from-sp buf off (+ bytes off)))
+                                            ((buf start end) (read-bytevector! buf string-port start end))))
+              (custom-port (make-input-port (lambda () (read-char string-port))
+                                            (constantly #t)
+                                            (lambda () (close-input-port string-port))
+                                            read-bytevector: read-bv-from-sp))
+              (uri (uri-reference "http://example.com"))
+              (req (make-request uri: uri method: 'POST
+                                 major: 1 minor: 0))
+              (log (with-server-response
+                    (lambda ()
+                      (with-input-from-request
+                       req
+                       `((lala . "testing")
+                         (the-file file: ,custom-port
+                                   filename: "str")
+                         ("more" . stuff))
+                       read-string))
+                    "HTTP/1.0 200 OK\r\n\r\n"))
+              (req (log-request log))
+              (h (request-headers req))
+              (boundary (header-param 'boundary 'content-type h))
+              (expected-data
+               (conc
+                "--" boundary "\r\n"
+                "Content-Disposition: form-data; name=\"lala\"\r\n\r\n"
+                "testing\r\n"
+                "--" boundary "\r\n"
+                "Content-Disposition: form-data; name=\"the-file\"; "
+                "filename=\"str\"\r\n"
+                "Content-Type: application/octet-stream\r\n\r\n"
+                "the file's contents\r\n"
+                "--" boundary "\r\n"
+                "Content-Disposition: form-data; name=\"more\"\r\n\r\n"
+                "stuff\r\n"
+                "--" boundary "--\r\n")))
 
       (test "Request method" 'POST (request-method req))
       (test "Content type is multipart"