Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

various portability improvements

Browse source
This commit is contained in:
Alex Shinn 2017-03-26 16:00:31 +09:00
parent 3b2e694372
commit c03ae08bbd
24 changed files with 190 additions and 100 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

@ -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

2
lib/chibi/base64-test.sld
View file

@ -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")

43
lib/chibi/base64.scm
View file

@ -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))
(limit (- end 2)))
(let ((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)
2)))
(bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
(enc (arithmetic-shift (extract-bit-field 4 0 b2) 2)))
(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))
(dst (make-string
(let ((src (make-bytevector encode-src-length))
(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)
effective-max-col)
(string-append "?=" nl "\t" prefix))
(string-join (string-chop (substring str first-max-col len)
effective-max-col)
(string-append "?=" nl "\t" prefix))
"?=")))))

27
lib/chibi/base64.sld
View file

@ -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)
(only (chibi) string-concatenate))
(import (scheme base)
(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"))

1
lib/chibi/io.sld
View file

@ -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")

3
lib/chibi/mime-test.sld
View file

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

9
lib/chibi/mime.scm
View file

@ -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)
(display (cdr h) out) (display "\r\n" out))
(write-string (car h) out) (write-string ": " 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

6
lib/chibi/mime.sld
View file

@ -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)
(chibi string) (chibi io)
(only (scheme base) bytevector-append write-bytevector))
(import (scheme base) (scheme char) (scheme write)
(chibi base64) (chibi quoted-printable)
(chibi string))
(include "mime.scm"))

5
lib/chibi/net.sld
View file

@ -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"))

18
lib/chibi/net/http.scm
View file

@ -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)
(assq headers 'Content-Type))
(if (or (assq 'content-type headers)
(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)
(assq headers 'Content-Length))
(if (or (assq 'content-length headers)
(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
;; mime-headers->list). Returns an alist of (name . value) for every
;; query or form parameter.
;;> Parse a form body with a given URI and MIME headers (as parsed
;;> with \scheme{mime-headers->list}). Returns an alist of
;;> \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

41
lib/chibi/net/http.sld
View file

@ -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)
(chibi net) (chibi io) (chibi uri) (chibi mime))
(srfi 27)
(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"))

4
lib/chibi/net/servlet.scm
View file

@ -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

16
lib/chibi/quoted-printable-test.sld Normal file
View file

@ -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))))

2
lib/chibi/quoted-printable.scm
View file

@ -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 "?=")))))

19
lib/chibi/quoted-printable.sld
View file

@ -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"))

6
lib/chibi/regexp-test.sld
View file

@ -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))

8
lib/chibi/scribble-test.sld
View file

@ -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

4
lib/chibi/snow/commands.sld
View file

@ -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"))

14
lib/chibi/snow/fort.sld
View file

@ -38,25 +38,13 @@
(import (only (chibi ast)
errno integer->error-string)
(only (chibi)
string-size exception-protect
call-with-input-string call-with-output-string)))
string-size exception-protect)))
(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

13
lib/chibi/snow/package.scm
View file

@ -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)

12
lib/chibi/snow/utils.sld
View file

@ -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"))

3
lib/chibi/string-test.sld
View file

@ -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 string))
(chibi test) (chibi string))
(cond-expand
(chibi
(import (only (chibi) string-cursor->index)))

26
lib/chibi/string.sld
View file

@ -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))
(blen (string-length b)))
(let lp ((i (if (pair? o) (car o) 0)))
(and (<= (+ i blen) alen)
(if (string=? b (substring a i (+ i blen)))
i
(lp (+ i 1))))))))))
(let ((alen (string-length a))
(blen (string-length b)))
(let lp ((i (if (pair? o) (car o) 0)))
(and (<= (+ i blen) alen)
(if (string=? b (substring a i (+ i blen)))
i
(lp (+ i 1))))))))))
(include "string.scm"))

5
lib/chibi/test.sld
View file

@ -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)