Update intarweb for CHICKEN 6

This is now using read-bytevector instead of read-string, and the
custom port constructor uses keyword arguments now.

Don't bother to use cond-expand to make it compatible with C5.
Instead, we can cut new C5 releases from the intarweb-2.x branch if
necessary.

2 files changed, 20 insertions, 20 deletions

diff --git a/intarweb.scm b/intarweb.scm
index ffea2a2..d2cca10 100644
--- a/intarweb.scm
+++ b/intarweb.scm
@@ -100,7 +100,7 @@
    basic-auth-param-subunparser digest-auth-param-subunparser
    )
 
-(import scheme (chicken base) (chicken foreign) (chicken irregex)
+(import scheme (scheme base) (chicken base) (chicken foreign) (chicken irregex)
         (chicken format) (chicken io) (chicken string)
         (chicken time posix) (chicken pathname) (chicken fixnum)
         (chicken condition) (chicken port) (chicken syntax)
@@ -153,8 +153,8 @@
 ;; that deal with headers.
 (define-record headers v)
 
-(define-record-printer (headers h out)
-  (fprintf out "#(headers: ~S)" (headers-v h)))
+(set-record-printer! headers (lambda (h out)
+  (fprintf out "#(headers: ~S)" (headers-v h))))
 
 (define headers->list headers-v)
 
@@ -271,7 +271,7 @@
                                  (fprintf port "~X\r\n~A\r\n" len s))))
                            (lambda ()         ; close
                              (close-output-port port))
-                           (lambda ()         ; flush
+                           force-output: (lambda ()
                              (flush-output port)))))
     ;; first "reserved" slot
     ;; Slot 7 should probably stay 'custom
@@ -312,12 +312,12 @@
                        (or (not position) (char-ready? port)))
                      (lambda ()         ; close
                        (close-input-port port))
-                     (lambda ()         ; peek-char
+                     peek-char: (lambda ()
                        (check-position)
                        (if position
                            (peek-char port)
                            #!eof))
-                     (lambda (p bytes buf off) ; read-string!
+                     read-bytevector: (lambda (p bytes buf off)
                        (let lp ((todo bytes)
                                 (total-bytes-read 0)
                                 (off off))
@@ -325,7 +325,7 @@
                          (if (or (not position) (= todo 0))
                              total-bytes-read
                              (let* ((n (min todo (- chunk-length position)))
-                                    (bytes-read (read-string! n buf port off)))
+                                    (bytes-read (read-bytevector! buf port off (+ off n))))
                                (set! position (+ position bytes-read))
                                (lp (- todo bytes-read)
                                    (+ total-bytes-read bytes-read)
diff --git a/tests/run.scm b/tests/run.scm
index 95a3990..f6f99ee 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,5 +1,5 @@
 (import scheme chicken.base chicken.port
-        chicken.condition chicken.time.posix srfi-1 
+        chicken.condition chicken.time.posix srfi-1
         test uri-common intarweb chicken.io chicken.format)
 
 ;; Below, there are specific tests for when these do have a value
@@ -138,7 +138,7 @@
     (let* ((headers (test-read-headers "Accept-Ranges: FoO")))
       (test "Case-insensitive"
             '(foo) (header-values 'accept-ranges headers))))
-  
+
   (test-group "symbol-parser"
     (let* ((headers (test-read-headers "Allow: FoO, foo")))
       (test "Case-sensitive"
@@ -235,7 +235,7 @@
           (test "Custom contents"
                 'security-through-obscurity
                 (header-param 'contents 'authorization headers))))))
-  
+
   (test-group "authenticate parser"
     (test-group "basic auth"
       (let ((headers (test-read-headers "WWW-Authenticate: Basic realm=\"WallyWorld\"")))
@@ -277,7 +277,7 @@
         (test "non-true stale value"
               #f
               (header-param 'stale 'www-authenticate headers)))))
-  
+
   (test-group "pragma-parser"
     (let ((headers (test-read-headers "Pragma: custom-value=10, no-cache")))
       (test "value"
@@ -482,7 +482,7 @@
           (header-value 'user-agent (test-read-headers "User-Agent: Mozilla/5.0\r\n")))
     (test "Product with comment"
           '(("Mozilla" #f "foo"))
-          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla (foo)\r\n")))    
+          (header-value 'user-agent (test-read-headers "User-Agent: Mozilla (foo)\r\n")))
     (test "Realistic product (comments, semicolons)"
           '(("Mozilla" "5.0" "X11; U; NetBSD amd64; en-US; rv:1.9.0.3") ("Gecko" "2008110501" #f) ("Minefield" "3.0.3" #f))
           (header-value 'user-agent (test-read-headers "User-Agent: Mozilla/5.0 (X11; U; NetBSD amd64; en-US; rv:1.9.0.3) Gecko/2008110501 Minefield/3.0.3\r\n")))
@@ -558,7 +558,7 @@
             (utc-time->seconds
              (get-param 'expires
                         (first (header-contents 'set-cookie headers)))))))
-  
+
   (test-group "cookie-parser"
     (let* ((headers (test-read-headers "Cookie: Foo=bar; $Path=/; qux=mooh; $unknown=something")))
       (test "Multiple cookies in the same header"
@@ -635,8 +635,8 @@
           "Foo: \"bar \\\" qux\", mooh\r\n"
           (test-unparse-headers `((foo "bar \" qux" "mooh"))))
     (test "Escaping control characters"
-          "Foo: \"bar\\\r\\\x01qux\"\r\n"
-          (test-unparse-headers `((foo "bar\r\x01qux"))))
+          "Foo: \"bar\\\r\\\x01;qux\"\r\n"
+          (test-unparse-headers `((foo "bar\r\x01;qux"))))
     ;; Unfortunately, there are no or very few HTTP implementations
     ;; which understand that newlines can be escaped with a backslash
     ;; in a quoted string. That's why we don't allow it.
@@ -644,7 +644,7 @@
     ;; of header (URLencoding, removing the newlines from cookies, etc)
     (test-error* "Embedded newlines throw an error"
                  (exn http unencoded-header)
-                 (test-unparse-headers `((foo "bar\n\x01qux"))))
+                 (test-unparse-headers `((foo "bar\n\x01;qux"))))
     (test "Alist"
           "Foo: Bar=qux, Mooh=mumble\r\n"
           (test-unparse-headers `((foo (bar . qux) (mooh . mumble)))))
@@ -668,7 +668,7 @@
           (test-unparse-headers `((etag #("\"hi there" raw)))))
     (test-error* "Embedded newlines in raw headers also throw an error"
                  (exn http unencoded-header)
-                 (test-unparse-headers `((foo #("bar\n\x01qux" raw))))))
+                 (test-unparse-headers `((foo #("bar\n\x01;qux" raw))))))
   (test-group "content-range unparser"
     (test "Full content-range"
           "Content-Range: bytes 500-999/1234\r\n"
@@ -763,7 +763,7 @@
     (test "Old-style cookie expires value"
           "Set-Cookie: foo=; Expires=Sunday, 20-Jul-08 15:23:42 GMT\r\n"
           (test-unparse-headers `((set-cookie #(("foo" . "")
-                                                ((expires . #(42 23 15 20 6 108 0 309 #f 0))))))))    
+                                                ((expires . #(42 23 15 20 6 108 0 309 #f 0))))))))
     (test "Secure (true)"
           "Set-Cookie: foo=bar; Secure\r\n"
           (test-unparse-headers `((set-cookie #(("foo" . "bar")
@@ -777,7 +777,7 @@
           "Set-Cookie: foo=bar; Path=/blah\r\n"
           (test-unparse-headers `((set-cookie #(("foo" . "bar")
                                                 ((path . ,(uri-reference "/blah"))
-                                                 (secure . #f))))))))  
+                                                 (secure . #f))))))))
   (test-group "authorization unparser"
     (test "Basic auth"
           "Authorization: Basic QWxpIEJhYmE6b3BlbiBzZXNhbWU=\r\n"
@@ -1180,7 +1180,7 @@
                   (update-response res status: 'unknown))
       (test "any status can be used when code and reason are given directly"
             "HTTP/1.1 999 No Way\r\n\r\ntest"
-            (test-write-response 
+            (test-write-response
              (update-response res code: 999 reason: "No Way")
              "test"))
       (test "defaults can be parameterized"