various portability improvements

Makefile

@@ -437,6 +437,7 @@ snowballs:
 	$(SNOW_CHIBI) package -r lib/chibi/show.sld lib/chibi/show/pretty.sld
 	$(SNOW_CHIBI) package lib/srfi/115.sld
 	$(SNOW_CHIBI) package lib/chibi/app.sld
+	$(SNOW_CHIBI) package lib/chibi/base64.sld
 	$(SNOW_CHIBI) package lib/chibi/binary-record.sld
 	$(SNOW_CHIBI) package lib/chibi/bytevector.sld
 	$(SNOW_CHIBI) package lib/chibi/config.sld
@@ -445,10 +446,12 @@ snowballs:
 	$(SNOW_CHIBI) package lib/chibi/crypto/sha2.sld
 	$(SNOW_CHIBI) package lib/chibi/filesystem.sld
 	$(SNOW_CHIBI) package lib/chibi/math/prime.sld
+	$(SNOW_CHIBI) package lib/chibi/mime.sld
 	$(SNOW_CHIBI) package lib/chibi/monad/environment.sld
 	$(SNOW_CHIBI) package lib/chibi/optional.sld
 	$(SNOW_CHIBI) package lib/chibi/parse.sld lib/chibi/parse/common.sld
 	$(SNOW_CHIBI) package lib/chibi/pathname.sld
+	$(SNOW_CHIBI) package lib/chibi/quoted-printable.sld
 	$(SNOW_CHIBI) package lib/chibi/regexp.sld lib/chibi/regexp/pcre.sld
 	$(SNOW_CHIBI) package lib/chibi/scribble.sld
 	$(SNOW_CHIBI) package lib/chibi/string.sld

lib/chibi/base64-test.sld

@@ -1,6 +1,6 @@
 (define-library (chibi base64-test)
   (export run-tests)
-  (import (chibi) (chibi base64) (chibi test))
+  (import (scheme base) (chibi base64) (chibi string) (chibi test))
   (begin
     (define (run-tests)
       (test-begin "base64")

lib/chibi/base64.scm

@@ -193,14 +193,15 @@
                  (current-output-port))))
     (cond
      ((not (binary-port? in))
-      (write-string (base64-decode-string (port->string in)) out))
+      (let ((str (port->string in)))
+        (write-string (base64-decode-string str) out)))
      (else
       (let ((src (make-bytevector decode-src-length))
             (dst (make-bytevector decode-dst-length)))
         (let lp ((offset 0))
           (let ((src-len
                  (+ offset
-                    (read-bytevector! decode-src-length src in offset))))
+                    (read-bytevector! src in offset decode-src-length))))
             (cond
              ((= src-len decode-src-length)
               ;; read a full chunk: decode, write and loop
@@ -209,12 +210,12 @@
                (lambda (src-offset dst-len b1 b2 b3)
                  (cond
                   ((and (< src-offset src-len)
-                        (eqv? #\= (string-ref src src-offset)))
+                        (eqv? #x3D (bytevector-u8-ref src src-offset)))
                    ;; done
                    (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
                      (write-bytevector dst out 0 dst-len)))
                   ((eqv? b1 *outside-char*)
-                   (write-string dst out 0 dst-len)
+                   (write-bytevector dst out 0 dst-len)
                    (lp 0))
                   (else
                    (write-bytevector dst out 0 dst-len)
@@ -237,7 +238,7 @@
                src 0 src-len dst
                (lambda (src-offset dst-len b1 b2 b3)
                  (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
-                   (write-string dst out 0 dst-len)))))))))))))
+                   (write-bytevector dst out 0 dst-len)))))))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; encoding
@@ -258,8 +259,7 @@
     res))
 
 (define (base64-encode-bytevector! bv start end res)
-  (let* ((res-len (bytevector-length res))
+  (let ((limit (- end 2)))
-         (limit (- end 2)))
     (let lp ((i start) (j 0))
       (if (>= i limit)
           (case (- end i)
@@ -271,7 +271,8 @@
                 (+ j 1)
                 (enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
                (bytevector-u8-set! res (+ j 2) (char->integer #\=))
-               (bytevector-u8-set! res (+ j 3) (char->integer #\=))))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))
+               (+ j 4)))
             ((2)
              (let ((b1 (bytevector-u8-ref bv i))
                    (b2 (bytevector-u8-ref bv (+ i 1))))
@@ -285,9 +286,11 @@
                (bytevector-u8-set!
                 res
                 (+ j 2)
-                (enc (arithmetic-shift (extract-bit-field 4 0 b2)
+                (enc (arithmetic-shift (extract-bit-field 4 0 b2) 2)))
-                                       2)))
+               (bytevector-u8-set! res (+ j 3) (char->integer #\=))
-               (bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
+               (+ j 4)))
+            (else
+             j))
           (let ((b1 (bytevector-u8-ref bv i))
                 (b2 (bytevector-u8-ref bv (+ i 1)))
                 (b3 (bytevector-u8-ref bv (+ i 2))))
@@ -316,17 +319,19 @@
                  (current-output-port))))
     (cond
      ((not (binary-port? in))
-      (write-string (base64-encode-string (port->string in)) out))
+      (let ((str (port->string in)))
+        (write-string (base64-encode-string str) out)))
      (else
-      (let ((src (make-string encode-src-length))
+      (let ((src (make-bytevector encode-src-length))
-            (dst (make-string
+            (dst (make-bytevector
                   (arithmetic-shift (quotient encode-src-length 3) 2))))
         (let lp ()
           (let ((n (read-bytevector! src in 0 2048)))
             (base64-encode-bytevector! src 0 n dst)
-            (write-bytevector dst out 0 (* 3 (quotient (+ n 3) 4)))
+            (write-bytevector dst out 0 (* 4 (quotient (+ n 2) 3)))
             (if (= n 2048)
-                (lp)))))))))
+                (lp)
+                (flush-output-port out)))))))))
 
 ;;> Return a base64 encoded representation of the string \var{str} as
 ;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
@@ -359,8 +364,8 @@
                (string-append
                 prefix (substring str 0 first-max-col) "?=" nl "\t" prefix)
                "")
-           (string-concatenate (string-chop (substring str first-max-col len)
+           (string-join (string-chop (substring str first-max-col len)
-                                            effective-max-col)
+                                     effective-max-col)
-                               (string-append "?=" nl "\t" prefix))
+                        (string-append "?=" nl "\t" prefix))
            "?=")))))
 

lib/chibi/base64.sld

@@ -3,6 +3,29 @@
   (export base64-encode base64-encode-string base64-encode-bytevector
           base64-decode base64-decode-string base64-decode-bytevector
           base64-encode-header)
-  (import (scheme base) (srfi 33) (chibi io)
+  (import (scheme base)
-          (only (chibi) string-concatenate))
+          (chibi string))
+  (cond-expand
+   ((library (srfi 33))
+    (import (srfi 33)))
+   (else
+    (import (srfi 60))
+    (begin
+      (define (%mask size) (bitwise-not (arithmetic-shift -1 size)))
+      (define (extract-bit-field size position n)
+        (bitwise-and (%mask size) (arithmetic-shift n (- position)))))))
+  (cond-expand
+   (chibi (import (chibi io)))
+   (else
+    (begin
+      (define (port->string in)
+        (let ((out (open-output-string)))
+          (let lp ()
+            (let ((ch (read-char in)))
+              (cond
+               ((eof-object? ch)
+                (get-output-string out))
+               (else
+                (write-char ch out)
+                (lp))))))))))
   (include "base64.scm"))

lib/chibi/io.sld

@@ -16,7 +16,6 @@
           string->utf8 utf8->string
           write-string write-u8 read-u8 peek-u8 send-file
           is-a-socket?
-          call-with-input-string call-with-output-string
           call-with-input-file call-with-output-file)
   (import (chibi) (chibi ast))
   (include-shared "io/io")

lib/chibi/mime-test.sld

@@ -1,7 +1,6 @@
 (define-library (chibi mime-test)
   (export run-tests)
-  (import (chibi) (chibi mime) (chibi test)
+  (import (scheme base) (chibi mime) (chibi string) (chibi test))
-          (only (scheme base) string->utf8 open-input-bytevector))
   (begin
     (define (run-tests)
       (test-begin "mime")

lib/chibi/mime.scm

@@ -18,7 +18,8 @@
 ;;> MIME headers.
 
 (define (assq-ref ls key . o)
-  (cond ((assq key ls) => cdr) (else (and (pair? o) (car o)))))
+  (cond ((and (pair? ls) (pair? (car ls)) (assq key ls)) => cdr)
+        (else (and (pair? o) (car o)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; simple matching instead of regexps
@@ -232,8 +233,8 @@
 (define (mime-write-headers headers out)
   (for-each
    (lambda (h)
-     (display (car h) out) (display ": " out)
+     (write-string (car h) out) (write-string ": " out)
-     (display (cdr h) out) (display "\r\n" out))
+     (write-string (cdr h) out) (write-string "\r\n" out))
    headers))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -408,7 +409,7 @@
                    (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x))
                    (let lp ((part-seed (kons-down headers seed)))
                      (let ((part-headers (mime-headers->list port)))
-                       (flush-output (current-error-port))
+                       (flush-output-port (current-error-port))
                        (tfold headers part-headers
                               part-seed boundary2
                               lp

lib/chibi/mime.sld

@@ -3,7 +3,7 @@
   (export assq-ref mime-header-fold mime-headers->list
           mime-parse-content-type mime-decode-header
           mime-message-fold mime-message->sxml mime-write-headers)
-  (import (chibi) (chibi base64) (chibi quoted-printable)
+  (import (scheme base) (scheme char) (scheme write)
-          (chibi string) (chibi io)
+          (chibi base64) (chibi quoted-printable)
-          (only (scheme base) bytevector-append write-bytevector))
+          (chibi string))
   (include "mime.scm"))

lib/chibi/net.sld

@@ -21,6 +21,9 @@
           get-peer-name
           ;; C structs
           sockaddr addrinfo)
-  (import (chibi) (chibi filesystem) (srfi 33))
+  (import (chibi) (chibi filesystem))
+  (cond-expand
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
   (include-shared "net")
   (include "net.scm"))

lib/chibi/net/http.scm

@@ -1,5 +1,5 @@
 ;; http.scm -- http client
-;; Copyright (c) 2009-2013 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2009-2017 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -231,8 +231,8 @@
 (define (http-post url body . o)
   (let* ((headers (if (pair? o) (car o) '()))
          (headers
-          (if (or (assq headers 'content-type)
+          (if (or (assq 'content-type headers)
-                  (assq headers 'Content-Type))
+                  (assq 'Content-Type headers))
               headers
               (let ((boundary (http-generate-boundary)))
                 `((Content-Type . ,(string-append
@@ -244,8 +244,8 @@
             (http-send-body headers body out)
             (get-output-bytevector out)))
          (headers
-          (if (or (assq headers 'content-length)
+          (if (or (assq 'content-length headers)
-                  (assq headers 'Content-Length))
+                  (assq 'Content-Length headers))
               headers
               `((Content-Length . ,(bytevector-length body))
                 ,@headers))))
@@ -292,15 +292,15 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; server utils
 
-;; read and parse a request line
+;;> Read and parse a request line.
 (define (http-parse-request . o)
   (let ((line (string-split
                (read-line (if (pair? o) (car o) (current-input-port)) 4096))))
     (cons (string->symbol (car line)) (cdr line))))
 
-;; Parse a form body with a given URI and MIME headers (as parsed with
+;;> Parse a form body with a given URI and MIME headers (as parsed
-;; mime-headers->list).  Returns an alist of (name . value) for every
+;;> with \scheme{mime-headers->list}).  Returns an alist of
-;; query or form parameter.
+;;> \scheme{(name . value)} for every query or form parameter.
 (define (http-parse-form uri headers . o)
   (let* ((in (if (pair? o) (car o) (current-input-port)))
          (type (assq-ref headers

lib/chibi/net/http.sld

@@ -6,6 +6,43 @@
           with-input-from-url
           http-parse-request http-parse-form)
   (import (scheme base) (scheme write) (scheme char) (scheme file)
-          (srfi 27) (srfi 39)
+          (srfi 27)
-          (chibi net) (chibi io) (chibi uri) (chibi mime))
+          (chibi uri) (chibi mime))
+  (cond-expand
+   (chicken
+    (import (only (chicken) parameterize))
+    (import (only (ports) make-input-port))
+    (import (only (tcp) tcp-connect))
+    (begin
+      (define (make-custom-binary-input-port read-bv)
+        (let ((bv (make-bytevector 1024))
+              (off 0)
+              (fill 0))
+          (define (refill!)
+            (set! off 0)
+            (set! fill (read-bv bv 0 1024)))
+          (make-input-port
+           (lambda ()
+             (if (>= off fill)
+                 (refill!))
+             (if (< off fill)
+                 (read-char (open-input-string ""))
+                 (let ((res (integer->char (bytevector-u8-ref bv off))))
+                   (set! off (+ 1 off))
+                   res)))
+           (lambda ()
+             (or (< off fill)
+                 (begin (refill!) (< off fill))))
+           (lambda () #f))))
+      (define (open-net-io host port . o)
+        (call-with-values (lambda () (tcp-connect host port))
+          (lambda (in out)
+            (list #f in out))))
+      (define (port->bytevector in)
+        (let ((out (open-output-bytevector)))
+          (do ((c (read-u8 in) (read-u8 in)))
+              ((eof-object? c) (get-output-bytevector out))
+            (write-u8 c out))))))
+   (else
+    (import (srfi 39) (chibi io) (chibi net))))
   (include "http.scm"))

lib/chibi/net/servlet.scm

@@ -90,7 +90,7 @@
   (let ((request2 (copy-request request))
         (uri (string->path-uri 'http uri)))
     (request-uri-set! request2 uri)
-    ;; NOTE: this looses form parameters
+    ;; NOTE: this loses form parameters
     (request-params-set! request2 (uri-query->alist (or (uri-query uri) "") #t))
     request2))
 
@@ -218,7 +218,7 @@
      (else
       (lp (cdr ls) res files)))))
 
-(define (servlet-parse-body! request)
+(define (servlet-parse-body! request . o)
   (let* ((headers (request-headers request))
          (ctype
           (mime-parse-content-type

lib/chibi/quoted-printable-test.sld

@@ -0,0 +1,16 @@
+(define-library (chibi quoted-printable-test)
+  (export run-tests)
+  (import (scheme base) (chibi quoted-printable) (chibi string) (chibi test))
+  (begin
+    (define (run-tests)
+      (test-begin "quoted-printable")
+
+      (test "J'interdis aux marchands de vanter trop leur marchandises. Car ils se font vite pédagogues et t'enseignent comme but ce qui n'est par essence qu'un moyen, et te trompant ainsi sur la route à suivre les voilà bientôt qui te dégradent, car si leur musique est vulgaire ils te fabriquent pour te la vendre une âme vulgaire."
+          (quoted-printable-decode-string
+           "J'interdis aux marchands de vanter trop leur marchandises. Car ils se font =
+vite p=C3=A9dagogues et t'enseignent comme but ce qui n'est par essence qu'=
+un moyen, et te trompant ainsi sur la route =C3=A0 suivre les voil=C3=A0 bi=
+ent=C3=B4t qui te d=C3=A9gradent, car si leur musique est vulgaire ils te f=
+abriquent pour te la vendre une =C3=A2me vulgaire."))
+
+      (test-end))))

lib/chibi/quoted-printable.scm

@@ -97,7 +97,7 @@
            (effective-max-col (- max-col prefix-length)))
       (bytevector-append
        (string->utf8 prefix)
-       (qp-encode (if (string? src) src (read-string #f src))
+       (qp-encode (if (string? src) src (port->string src))
                   start-col effective-max-col separator)
        (string->utf8 "?=")))))
 

lib/chibi/quoted-printable.sld

@@ -5,5 +5,22 @@
           quoted-printable-encode-header
           quoted-printable-decode quoted-printable-decode-string
           quoted-printable-decode-bytevector)
-  (import (scheme base) (srfi 33) (chibi io))
+  (import (scheme base))
+  (cond-expand
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
+  (cond-expand
+   (chibi (import (chibi io)))
+   (else
+    (begin
+      (define (port->string in)
+        (let ((out (open-output-string)))
+          (let lp ()
+            (let ((ch (read-char in)))
+              (cond
+               ((eof-object? ch)
+                (get-output-string out))
+               (else
+                (write-char ch out)
+                (lp))))))))))
   (include "quoted-printable.scm"))

lib/chibi/regexp-test.sld

@@ -238,12 +238,6 @@
       (test " abc d ef " (regexp-replace-all '(+ space) "  abc \t\n d ef  " " "))
 
       (let ()
-        (define (call-with-input-string str proc)
-          (proc (open-input-string str)))
-        (define (call-with-output-string proc)
-          (let ((out (open-output-string)))
-            (proc out)
-            (get-output-string out)))
         (define (subst-matches matches input subst)
           (define (submatch n)
             (regexp-match-submatch matches n))

lib/chibi/scribble-test.sld

@@ -1,14 +1,8 @@
 (define-library (chibi scribble-test)
   (export run-tests)
-  (import (scheme base) (scheme write) (chibi scribble)
+  (import (scheme base) (scheme write) (chibi scribble) (chibi string)
           (only (chibi test) test-begin test test-end))
   (begin
-    (define (call-with-output-string proc)
-      (let ((out (open-output-string)))
-        (proc out)
-        (get-output-string out)))
-    (define (call-with-input-string str proc)
-      (proc (open-input-string str)))
     (define (test-scribble expect str)
       (test (call-with-output-string (lambda (out) (write str out)))
           expect

lib/chibi/snow/commands.sld

@@ -27,7 +27,6 @@
           (scheme write)
           (srfi 1)
           (srfi 27)
-          (srfi 33)
           (srfi 95)
           (chibi snow interface)
           (chibi snow package)
@@ -56,4 +55,7 @@
           (chibi temp-file)
           (chibi uri)
           (chibi zlib))
+  (cond-expand
+   ((library (srfi 33)) (import (srfi 33)))
+   (else (import (srfi 60))))
   (include "commands.scm"))

lib/chibi/snow/fort.sld

@@ -38,25 +38,13 @@
     (import (only (chibi ast)
                   errno integer->error-string)
             (only (chibi)
-                  string-size exception-protect
+                  string-size exception-protect)))
-                  call-with-input-string call-with-output-string)))
    (else
     (begin
       (define (errno) 0)
       (define (integer->error-string n)
         (string-append "errno: " (number->string n)))
       (define string-size string-length)
-      (define (call-with-input-string str proc)
-        (let* ((in (open-input-string str))
-               (res (proc in)))
-          (close-input-port in)
-          res))
-      (define (call-with-output-string proc)
-        (let ((out (open-output-string)))
-          (proc out)
-          (let ((res (get-output-string out)))
-            (close-output-port out)
-            res)))
       (define (with-exception-protect thunk final)
         (let* ((finalized? #f)
                (run-finalize

lib/chibi/snow/package.scm

@@ -25,19 +25,6 @@
         ((eof-object? c) (get-output-bytevector out))
       (write-u8 c out))))
 
-(define (call-with-input-string str proc)
-  (let* ((in (open-input-string str))
-         (res (proc in)))
-    (close-input-port in)
-    res))
-
-(define (call-with-output-string proc)
-  (let ((out (open-output-string)))
-    (proc out)
-    (let ((res (get-output-string out)))
-      (close-output-port out)
-      res)))
-
 ;; general utils
 
 (define (read-from-string str)

lib/chibi/snow/utils.sld

@@ -11,9 +11,19 @@
           (scheme write)
           (scheme process-context)
           (srfi 1)
-          (chibi io)
           (chibi net http)
           (chibi pathname)
           (chibi string)
           (chibi uri))
+  (cond-expand
+   (chibi (import (chibi io)))
+   (chicken
+    (begin
+      (define (port->bytevector in) (read-bytevector #f in))
+      (define (file->bytevector in)
+        (call-with-input-file in port->bytevector))
+      (define (call-with-output-string proc)
+        (let ((out (open-output-string)))
+          (proc out)
+          (get-output-string out))))))
   (include "utils.scm"))

lib/chibi/string-test.sld

@@ -1,8 +1,7 @@
 (define-library (chibi string-test)
   (export run-tests)
   (import (scheme base) (scheme char)
-          (only (chibi test) test-begin test test-end)
+          (chibi test) (chibi string))
-          (chibi string))
   (cond-expand
    (chibi
     (import (only (chibi) string-cursor->index)))

lib/chibi/string.sld

@@ -19,7 +19,8 @@
    string-find string-find-right string-find? string-skip string-skip-right
    string-fold string-fold-right string-map string-for-each
    string-contains make-string-searcher
-   string-downcase-ascii string-upcase-ascii)
+   string-downcase-ascii string-upcase-ascii
+   call-with-input-string call-with-output-string)
   (cond-expand
    (chibi
     (import (chibi) (chibi ast) (chibi char-set base))
@@ -73,10 +74,17 @@
               (lp (cdr ls)))))
           (get-output-string out)))
       (define string-size string-length)
+      (define (call-with-input-string str proc)
+        (let* ((in (open-input-string str))
+               (res (proc in)))
+          (close-input-port in)
+          res))
       (define (call-with-output-string proc)
         (let ((out (open-output-string)))
           (proc out)
-          (get-output-string out))))))
+          (let ((res (get-output-string out)))
+            (close-output-port out)
+            res))))))
   (cond-expand
    (chibi)
    ((library (srfi 13))
@@ -84,11 +92,11 @@
    (else
     (begin
       (define (string-contains a b . o)  ; really, stupidly slow
-       (let ((alen (string-length a))
+        (let ((alen (string-length a))
-             (blen (string-length b)))
+              (blen (string-length b)))
-         (let lp ((i (if (pair? o) (car o) 0)))
+          (let lp ((i (if (pair? o) (car o) 0)))
-           (and (<= (+ i blen) alen)
+            (and (<= (+ i blen) alen)
-                (if (string=? b (substring a i (+ i blen)))
+                 (if (string=? b (substring a i (+ i blen)))
-                    i
+                     i
-                    (lp (+ i 1))))))))))
+                     (lp (+ i 1))))))))))
   (include "string.scm"))

lib/chibi/test.sld

@@ -18,6 +18,11 @@
   (cond-expand
    (chibi
     (import (only (chibi) pair-source print-exception protect)))
+   (chicken
+    (import (only (chicken) print-error-message))
+    (begin
+      (define (pair-source x) #f)
+      (define print-exception print-error-message)))
    (else
     (begin
       (define (pair-source x) #f)