From 3bf6fcb24c3196adcb583f70b724ffed404d2dc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 9 Oct 2023 13:09:08 +0200 Subject: Handle crashes in tests! Unhandled exceptions thrown during tests are now caught, and properly repported. This also allows the tests to run to completion, and print their final summary (which I previously believed was broken when running in multiple threads). Also add --help flag to testrunner... --- module/hnh/test/testrunner.scm | 10 +++-- testrunner.scm | 96 +++++++++++++++++++++++++++++------------- 2 files changed, 74 insertions(+), 32 deletions(-) diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm index 38df0ee1..b3951c34 100644 --- a/module/hnh/test/testrunner.scm +++ b/module/hnh/test/testrunner.scm @@ -6,8 +6,8 @@ :use-module (ice-9 pretty-print) :use-module (ice-9 format) :use-module (ice-9 curried-definitions) - :export (verbose? construct-test-runner) - ) + :export (verbose? construct-test-runner + test-runner-test-name/description)) (define verbose? (make-parameter #f)) @@ -107,8 +107,12 @@ (with-output-to-string (lambda () (display - (red (format #f "Test failed: ~a~%" + (yellow (format #f "Test failed: ~a~%" (test-runner-test-name/description runner)))) + (display + (yellow + (format #f " Path: ~s~%" + (cdr (test-runner-group-path runner))))) (test-runner-describe-error runner 0))) err-queue)) diff --git a/testrunner.scm b/testrunner.scm index 267e3c17..e8fdcc2b 100755 --- a/testrunner.scm +++ b/testrunner.scm @@ -1,8 +1,8 @@ #!/usr/bin/env bash # -*- mode: scheme; geiser-scheme-implementation: guile -*- -make calp -make unit-test-deps +make --silent calp +make --silent unit-test-deps root=$(dirname "$(realpath "$0")") eval "$(env __PRINT_ENVIRONMENT=1 "${root}/calp")" @@ -30,6 +30,7 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@" (hnh util atomic-stack) (hnh util atomic-queue) (hnh test testrunner) + (hnh test util) ((hnh util io) :select (displayln)) (crypto) (ice-9 getopt-long) @@ -111,11 +112,36 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@" (define* (maybe-with-code-coverage thunk key: (coverage? #f)) (if coverage? - (with-code-coverage - (lambda () (catch #t thunk (lambda _ #f)))) - (values #f (catch #t thunk (lambda _ #f))))) - -(define* (prepare-jobs test-files key: (coverage? #f)) + (with-code-coverage thunk) + (values #f (thunk)))) + + +(define (format-test-runner-crash-message args) + (with-output-to-string + (lambda () + (display + (red + (format + #f + "Test crashed unexpectedly, after: ~s~%" + (test-runner-test-name/description (test-runner-current))))) + (display (yellow " All further tests in file will be skipped")) + (newline) + (format #t " In file ~s, sightly after line ~a~%" + (test-result-ref (test-runner-current) 'source-file) + (test-result-ref (test-runner-current) 'source-line)) + + (apply (case-lambda ((err proc fmt args data) + (if proc + (format #t " ~a thrown in ~a. ~?~%" + err proc fmt args) + (format #t "~a thrtown. ~?~%" + err fmt args))) + (args (format #t " ~s~%" args))) + args)))) + + +(define* (prepare-jobs test-files error-queue key: (coverage? #f)) (for entry in test-files (job jobname: (basename entry) @@ -124,21 +150,27 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@" (parameterize ((current-filename (basename entry))) (test-begin entry) (push! (test-runner-get) runners) - (let ((coverage module-names - (maybe-with-code-coverage - (lambda () (load entry)) - coverage?: coverage?))) - (let ((tested-files (map module->source-file module-names))) - (test-end entry) - (if coverage - (let ((lcov-data - (call-with-output-string - (lambda (port) (coverage-data->lcov coverage port))))) - (filter (lambda (coverage) - (member (filename coverage) - tested-files)) - (parse-coverage lcov-data))) - '())))))))) + (define-values (coverage module-names) + (catch #t + (lambda () + (maybe-with-code-coverage + (lambda () (load entry)) + coverage?: coverage?)) + (lambda args + (enqueue! (format-test-runner-crash-message args) + error-queue) + (values #f '())))) + (define tested-files (map module->source-file module-names)) + (test-end) + (if coverage + (let ((lcov-data + (call-with-output-string + (lambda (port) (coverage-data->lcov coverage port))))) + (filter (lambda (coverage) + (member (filename coverage) + tested-files)) + (parse-coverage lcov-data))) + '())))))) (define* (make-work-pool jobs key: (thread-count 1)) @@ -205,24 +237,27 @@ Flags: --verbose|-v Enables verbose output. This can also be done by setting the environment variable VERBOSE. ---suite +--suite path Limit execution to a single test suite. Should be given as a directory, and that directory should contain a number of test files. See files in tests/unit for available suites. Mutualy exclusive with --file. ---file + + Example: tests/unit/general +--file filename Only runs tests from the given file. Mutually exlusive with --suite. --list|-l Don't run test, but list all files which would have been ran. ---nice +--nice increment How much do incrument the nice value ---threads +--threads count How many threads to spawn for running tests. --coverage [output-filename] Generate code coverage data, this causes the tests to be quite a bit slower. --coverage-supplement supplement-file + ") @@ -243,6 +278,7 @@ Flags: (define options (getopt-long args option-spec)) (when (option-ref options 'help #f) + (display help) (exit 0)) (when (option-ref options 'verbose (getenv "VERBOSE")) @@ -259,7 +295,9 @@ Flags: (define error-queue (atomic-queue)) - (test-runner-factory (construct-test-runner print error-queue)) + (test-runner-factory (construct-test-runner + print + error-queue)) (define coverage (let ((cov (option-ref options 'coverage #f))) @@ -298,7 +336,7 @@ Flags: (test-begin "Universe") (let ((results (thread-join! (make-work-pool - (prepare-jobs test-files coverage?: coverage) + (prepare-jobs test-files error-queue coverage?: coverage) thread-count: (string->number (option-ref options 'threads "1")))))) @@ -315,7 +353,7 @@ Flags: (display "TN:") (newline) (for-each output-coverage merged-coverages)))) - (display "== Gathered errors ==\n") + (format #t "~%== Gathered errors ==~%") (let loop () (cond ((dequeue! error-queue) => (lambda (entry) -- cgit v1.2.3