diff options
| author | Peter Bex <peter@more-magic.net> | 2024-09-12 15:41:24 +0200 |
|---|---|---|
| committer | Peter Bex <peter@more-magic.net> | 2024-09-12 15:41:24 +0200 |
| commit | 072f058ff66ee8e2e7865307040ab5e9c8c75b48 (patch) | |
| tree | bce4601125812fe219152ce29a466748876184bb /tests/testlib.scm | |
| parent | 0f6fd2e7ceafb51971ca4d90583d68637ddecc4a (diff) | |
| download | spiffy-072f058ff66ee8e2e7865307040ab5e9c8c75b48.tar.gz | |
Add support for CHICKEN 66.4
This is backwards-compatible - there are only a handful of changes
needed, so we don't have to make a hard break here.
Diffstat (limited to 'tests/testlib.scm')
| -rw-r--r-- | tests/testlib.scm | 16 |
1 files changed, 14 insertions, 2 deletions
diff --git a/tests/testlib.scm b/tests/testlib.scm index f706753..d124554 100644 --- a/tests/testlib.scm +++ b/tests/testlib.scm @@ -3,6 +3,10 @@ (chicken tcp) (chicken process) (chicken file posix) uri-common intarweb srfi-18) +(cond-expand + (chicken-6) + (else (define read-bytevector read-string))) + (server-port (string->number (or (get-environment-variable "SPIFFY_TEST_PORT") "8080"))) @@ -67,7 +71,7 @@ ;;;; test tools -(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t)) +(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t) (binary #f)) (set! response-error? #f) (let ((uri (uri-reference (if absolute-uri (sprintf "http://~A:~A~A" host (server-port) file) @@ -80,7 +84,8 @@ headers: req-headers port: out))) (write-request req) (let* ((resp (read-response in)) - (str (read-string (header-value 'content-length (response-headers resp)) in))) + (str ((if binary read-bytevector read-string) + (header-value 'content-length (response-headers resp)) in))) (close-output-port out) (close-input-port in) (if get-headers @@ -94,6 +99,13 @@ ((_ ?text ?code-expected ?args ...) (test ?text ?code-expected (car (fetch-file ?args ...)))))) +(define-syntax test-binary-response + (syntax-rules () + ((_ ?text (?code-expected ?contents-expected) ?args ...) + (test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ... binary: #t))) + ((_ ?text ?code-expected ?args ...) + (test ?text ?code-expected (car (fetch-file ?args ... binary: #t)))))) + (define-syntax test-header (syntax-rules () ((_ ?text ?header-name (?header-values ...) ?args ...) |