build-system/gnu: Dump test suite logs upon 'check' failure.

Suggested by Mark H Weaver <mhw@netris.org>.

* guix/build/gnu-build-system.scm (dump-file-contents): New procedure.
(%test-suite-log-regexp): New variable.
(check): Add #:test-suite-log-regexp.  Catch 'invoke-error?' and call
'dump-file-contents' upon error.
This commit is contained in:
Ludovic Courtès 2018-03-19 10:50:05 +01:00
parent 4735610ee3
commit 88b87c352f
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5

View file

@ -33,6 +33,7 @@ (define-module (guix build gnu-build-system)
#:use-module (rnrs io ports)
#:export (%standard-phases
%license-file-regexp
dump-file-contents
gnu-build))
;; Commentary:
@ -335,15 +336,44 @@ (define* (build #:key (make-flags '()) (parallel-build? #t)
'())
,@make-flags)))
(define* (dump-file-contents directory file-regexp
#:optional (port (current-error-port)))
"Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP."
(define (dump file)
(let ((prefix (string-append "\n--- " file " ")))
(display (if (< (string-length prefix) 78)
(string-pad-right prefix 78 #\---)
prefix)
port)
(display "\n\n" port)
(call-with-input-file file
(lambda (log)
(dump-port log port)))
(display "\n" port)))
(for-each dump (find-files directory file-regexp)))
(define %test-suite-log-regexp
;; Name of test suite log files as commonly found in GNU-based build systems
;; and CMake.
"^(test-?suite\\.log|LastTestFailed\\.log)$")
(define* (check #:key target (make-flags '()) (tests? (not target))
(test-target "check") (parallel-tests? #t)
(test-suite-log-regexp %test-suite-log-regexp)
#:allow-other-keys)
(if tests?
(apply invoke "make" test-target
`(,@(if parallel-tests?
`("-j" ,(number->string (parallel-job-count)))
'())
,@make-flags))
(guard (c ((invoke-error? c)
;; Dump the test suite log to facilitate debugging.
(display "\nTest suite failed, dumping logs.\n"
(current-error-port))
(dump-file-contents "." test-suite-log-regexp)
(raise c)))
(apply invoke "make" test-target
`(,@(if parallel-tests?
`("-j" ,(number->string (parallel-job-count)))
'())
,@make-flags)))
(format #t "test suite not run~%"))
#t)