diff --git a/functional-tests/cache-functional-tests.scm b/functional-tests/cache-functional-tests.scm index 8627abf..db8c0c0 100644 --- a/functional-tests/cache-functional-tests.scm +++ b/functional-tests/cache-functional-tests.scm @@ -5,6 +5,7 @@ (functional-tests) (cache-xml) (fmt fmt) + (process) (temp-file) (srfi s8 receive)) diff --git a/functional-tests/functional-tests.scm b/functional-tests/functional-tests.scm index c0c8fb8..5bb20b4 100644 --- a/functional-tests/functional-tests.scm +++ b/functional-tests/functional-tests.scm @@ -2,15 +2,8 @@ (functional-tests) (export - info - slurp-file - run - run-with-exit-code - run-ok - run-fail - scenario scenarios add-scenario @@ -32,11 +25,12 @@ (chezscheme) (fmt fmt) (list-utils) + (logging) + (process) (temp-file) (thin-xml) (utils) - (srfi s8 receive) - (only (srfi s1 lists) drop-while)) + (srfi s8 receive)) ;;;-------------------------------------------------------------------- @@ -46,74 +40,6 @@ (vector-sort compare v)) - (define (chomp line) - (list->string - (reverse - (drop-while char-whitespace? - (reverse (string->list line)))))) - - ;; FIXME: write a decent log library - (define info-lines '()) - - (define (info . args) - (set! info-lines (cons (apply fmt #f args) - info-lines))) - - ;;;-------------------------------------------------------------------- - - (define (slurp-file path) - (define (slurp) - (let ((output (get-string-all (current-input-port)))) - (if (eof-object? output) - output - (chomp output)))) - - (with-input-from-file path slurp)) - - ;;;-------------------------------------------------------------------- - ;;; Run a sub process and capture it's output. - ;;; Ideally we'd use open-process-ports, but that loses us the exit code which - ;;; we need for testing. So we use system, and redirect stderr and stdout to - ;;; temporary files, and subsequently read them in. Messy, but fine for tests. - - (define (build-command-line cmd-and-args) - (apply fmt #f (map dsp (intersperse " " cmd-and-args)))) - - (define cwd "/tmp") - - (define (run . cmd-and-args) - (with-temp-file (stdout-file stderr-file) - (let ((cmd (fmt #f - (dsp (build-command-line cmd-and-args)) - (dsp " > ") - (dsp stdout-file) - (dsp " 2> ") - (dsp stderr-file)))) - (info (dsp "cmd: ") (dsp cmd)) - (let ((exit-code (system cmd))) - (values exit-code - (slurp-file stdout-file) - (slurp-file stderr-file)))))) - - (define (run-with-exit-code pred cmd-and-args) - (receive (exit-code stdout stderr) (apply run cmd-and-args) - (if (pred exit-code) - (values stdout stderr) - (begin - (info (fmt #f (dsp "stdout: ") stdout)) - (info (fmt #f (dsp "stderr: ") stderr)) - (fail (fmt #f (dsp "unexpected exit code (") - (num exit-code) - (dsp ")"))))))) - - (define (run-ok . cmd-and-args) - (run-with-exit-code zero? cmd-and-args)) - - (define (run-fail . cmd-and-args) - (define (not-zero? x) (not (zero? x))) - - (run-with-exit-code not-zero? cmd-and-args)) - ;;;-------------------------------------------------------------------- (define-record-type scenario (fields desc thunk)) @@ -179,12 +105,17 @@ (define-syntax define-scenario (lambda (x) (syntax-case x () - ((k keys desc b1 b2 ...) - #'(add-scenario 'keys - (make-scenario desc - (lambda () - (with-dir (test-dir "." 'keys) - b1 b2 ...)))))))) + ((k keys desc b1 b2 ...) + #'(add-scenario 'keys + (make-scenario desc + (lambda () + (with-dir (test-dir "." 'keys) + (with-log-port (open-file-output-port + (string-append (working-directory) "/log.txt") + (file-options no-fail) + (buffer-mode line) + (native-transcoder)) + b1 b2 ...))))))))) (define (fail msg) (raise (condition diff --git a/functional-tests/thin-functional-tests.scm b/functional-tests/thin-functional-tests.scm index 95adbcd..f4f40cc 100644 --- a/functional-tests/thin-functional-tests.scm +++ b/functional-tests/thin-functional-tests.scm @@ -7,6 +7,7 @@ (chezscheme) (fmt fmt) (functional-tests) + (process) (temp-file) (thin-xml) (srfi s8 receive) diff --git a/functional-tests/utils.scm b/functional-tests/utils.scm index c47b43b..8ef55df 100644 --- a/functional-tests/utils.scm +++ b/functional-tests/utils.scm @@ -2,8 +2,11 @@ (utils) (export inc! dec! - swap!) - (import (rnrs)) + swap! + slurp-file + chomp) + (import (chezscheme) + (only (srfi s1 lists) drop-while)) (define-syntax inc! (syntax-rules () @@ -21,4 +24,20 @@ (let ((tmp x)) (set! x y) (set! y tmp))))) + + (define (slurp-file path) + (define (slurp) + (let ((output (get-string-all (current-input-port)))) + (if (eof-object? output) + output + (chomp output)))) + + (with-input-from-file path slurp)) + + (define (chomp line) + (list->string + (reverse + (drop-while char-whitespace? + (reverse (string->list line)))))) + )