From ee715201ae784e840b6136393289e6dbd6f4c540 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Tue, 18 Apr 2017 18:51:06 +0200 Subject: [PATCH] gpgscm: Emit JUnit-style XML reports. * tests/gpgscm/Makefile.am (EXTRA_DIST): Add new file. * tests/gpgscm/lib.scm (string-translate): New function. * tests/gpgscm/main.c (main): Load new file. * tests/gpgscm/tests.scm (dirname): New function. (test-pool): Record execution times, emit XML report. (test): Record execution times, record log file name, emit XML report. (run-tests-parallel): Write XML report. (run-tests-sequential): Likewise. * tests/gpgscm/xml.scm: New file. * tests/gpgme/Makefile.am (CLEANFILES): Add 'report.xml'. * tests/gpgsm/Makefile.am: Likewise. * tests/migrations/Makefile.am: Likewise. * tests/openpgp/Makefile.am: Likewise. Signed-off-by: Justus Winter --- tests/gpgme/Makefile.am | 2 +- tests/gpgscm/Makefile.am | 1 + tests/gpgscm/lib.scm | 7 ++ tests/gpgscm/main.c | 2 + tests/gpgscm/tests.scm | 110 ++++++++++++++++++++++++--- tests/gpgscm/xml.scm | 142 +++++++++++++++++++++++++++++++++++ tests/gpgsm/Makefile.am | 2 +- tests/migrations/Makefile.am | 2 +- tests/openpgp/Makefile.am | 2 +- 9 files changed, 256 insertions(+), 14 deletions(-) create mode 100644 tests/gpgscm/xml.scm diff --git a/tests/gpgme/Makefile.am b/tests/gpgme/Makefile.am index daf757283..37485e741 100644 --- a/tests/gpgme/Makefile.am +++ b/tests/gpgme/Makefile.am @@ -50,7 +50,7 @@ xcheck: EXTRA_DIST = gpgme-defs.scm run-tests.scm setup.scm wrap.scm -CLEANFILES = *.log +CLEANFILES = *.log report.xml # We need to depend on a couple of programs so that the tests don't # start before all programs are built. diff --git a/tests/gpgscm/Makefile.am b/tests/gpgscm/Makefile.am index dc999fbcc..1bdd3737b 100644 --- a/tests/gpgscm/Makefile.am +++ b/tests/gpgscm/Makefile.am @@ -25,6 +25,7 @@ EXTRA_DIST = \ lib.scm \ repl.scm \ t-child.scm \ + xml.scm \ tests.scm \ gnupg.scm \ time.scm diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm index cafca8dd4..258f6925b 100644 --- a/tests/gpgscm/lib.scm +++ b/tests/gpgscm/lib.scm @@ -199,6 +199,13 @@ (assert (string-contains? "Hallo" "llo")) (assert (not (string-contains? "Hallo" "olla"))) +;; Translate characters. +(define (string-translate s from to) + (list->string (map (lambda (c) + (let ((i (string-index from c))) + (if i (string-ref to i) c))) (string->list s)))) +(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar")) + ;; Read a word from port P. (define (read-word . p) (list->string diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c index 5e04d978e..e4b535e78 100644 --- a/tests/gpgscm/main.c +++ b/tests/gpgscm/main.c @@ -312,6 +312,8 @@ main (int argc, char **argv) err = load (sc, "lib.scm", 0, 1); if (! err) err = load (sc, "repl.scm", 0, 1); + if (! err) + err = load (sc, "xml.scm", 0, 1); if (! err) err = load (sc, "tests.scm", 0, 1); if (! err) diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm index b2dcc54e2..31189774a 100644 --- a/tests/gpgscm/tests.scm +++ b/tests/gpgscm/tests.scm @@ -223,6 +223,10 @@ (substring path 0 (- (string-length path) (string-length suffix))) path))) +(define (dirname path) + (let ((i (string-rindex path #\/))) + (if i (substring path 0 i) "."))) + ;; Helper for (pipe). (define :read-end car) (define :write-end cadr) @@ -511,7 +515,9 @@ (let ((names (map (lambda (t) t::name) unfinished)) (pids (map (lambda (t) t::pid) unfinished))) (for-each - (lambda (test retcode) (test:::set! 'retcode retcode)) + (lambda (test retcode) + (test::set-end-time!) + (test:::set! 'retcode retcode)) (map pid->test pids) (wait-processes (map stringify names) pids #t))))) (current-environment)) @@ -539,7 +545,15 @@ (length skipped') "skipped.") (print-tests failed' "Failed tests:") (print-tests skipped' "Skipped tests:") - (length failed'))))))) + (length failed'))) + + (define (xml) + (xx::document + (xx::tag 'testsuites + `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance") + ("xsi:noNamespaceSchemaLocation" + "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd")) + (map (lambda (t) (t::xml)) procs)))))))) (define (verbosity n) (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) @@ -549,6 +563,23 @@ ;; A single test. (define test + (begin + + ;; Private definitions. + + (define (isotime->junit t) + "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}" + "20170418T145809" + (string-append (substring t 0 4) + "-" + (substring t 4 6) + "-" + (substring t 6 11) + ":" + (substring t 11 13) + ":" + (substring t 13 15))) + (package (define (scm setup name path . args) ;; Start the process. @@ -568,14 +599,34 @@ (define (new name directory spawn pid retcode logfd) (package + + ;; XXX: OO glue. + (define self (current-environment)) (define (:set! key value) (eval `(set! ,key ,value) (current-environment)) (current-environment)) + + ;; The log is written here. + (define log-file-name "not set") + + ;; Record time stamps. + (define timestamp #f) + (define start-time 0) + (define end-time 0) + + (define (set-start-time!) + (set! timestamp (isotime->junit (get-isotime))) + (set! start-time (get-time))) + (define (set-end-time!) + (set! end-time (get-time))) + (define (open-log-file) - (let ((filename (string-append (basename name) ".log"))) - (catch '() (unlink filename)) - (open filename (logior O_RDWR O_BINARY O_CREAT) #o600))) + (set! log-file-name (string-append (basename name) ".log")) + (catch '() (unlink log-file-name)) + (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600)) + (define (run-sync . args) + (set-start-time!) (letfd ((log (open-log-file))) (with-working-directory directory (let* ((p (inbound-pipe)) @@ -588,25 +639,62 @@ (report) (current-environment)) (define (run-sync-quiet . args) + (set-start-time!) (with-working-directory directory - (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)) - (set! retcode (wait-process name pid #t))) + (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))) + (set! retcode (wait-process name pid #t)) + (set-end-time!) (current-environment)) (define (run-async . args) + (set-start-time!) (let ((log (open-log-file))) (with-working-directory directory (set! pid (spawn args CLOSED_FD log log))) (set! logfd log)) (current-environment)) (define (status) - (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) - (if (not t) "FAIL" (cadr t)))) + (let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))) + (if (not t) 'FAIL (cadr t)))) + (define (status-string) + (cadr (assoc (status) '((PASS "PASS") + (SKIP "SKIP") + (ERROR "ERROR") + (FAIL "FAIL"))))) (define (report) (unless (= logfd CLOSED_FD) (seek logfd 0 SEEK_SET) (splice logfd STDERR_FILENO) (close logfd)) - (echo (string-append (status) ":") name)))))) + (echo (string-append (status-string) ":") name)) + + (define (xml) + (xx::tag + 'testsuite + `((name ,name) + (time ,(- end-time start-time)) + (package ,(dirname name)) + (id 0) + (timestamp ,timestamp) + (hostname "unknown") + (tests 1) + (failures ,(if (eq? FAIL (status)) 1 0)) + (errors ,(if (eq? ERROR (status)) 1 0))) + (list + (xx::tag 'properties) + (xx::tag 'testcase + `((name ,(basename name)) + (classname ,(string-translate (dirname name) "/" ".")) + (time ,(- end-time start-time))) + `(,@(case (status) + ((PASS) '()) + ((SKIP) (list (xx::tag 'skipped))) + ((ERROR) (list + (xx::tag 'error '((message "Unknown error."))))) + (else + (list (xx::tag 'failure '((message "Unknown error.")))))))) + (xx::tag 'system-out '() + (list (xx::textnode (read-all (open-input-file log-file-name))))) + (xx::tag 'system-err '() (list (xx::textnode ""))))))))))) ;; Run the setup target to create an environment, then run all given ;; tests in parallel. @@ -615,6 +703,7 @@ (if (null? tests') (let ((results (pool::wait))) (for-each (lambda (t) (t::report)) (reverse results::procs)) + ((results::xml) (open-output-file "report.xml")) (exit (results::report))) (let ((wd (mkdtemp-autoremove)) (test (car tests'))) @@ -628,6 +717,7 @@ (let loop ((pool (test-pool::new '())) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) + ((results::xml) (open-output-file "report.xml")) (exit (results::report))) (let ((wd (mkdtemp-autoremove)) (test (car tests'))) diff --git a/tests/gpgscm/xml.scm b/tests/gpgscm/xml.scm new file mode 100644 index 000000000..771ec3616 --- /dev/null +++ b/tests/gpgscm/xml.scm @@ -0,0 +1,142 @@ +;; A tiny XML library. +;; +;; Copyright (C) 2017 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see . + +(define xx + (begin + + ;; Private declarations. + (define quote-text + '((#\< "<") + (#\> ">") + (#\& "&"))) + + (define quote-attribute-' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\' "'"))) + + (define quote-attribute-'' + '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))) + + (define (escape-string quotation string sink) + ;; This implementation is a bit awkward because iteration is so + ;; slow in TinySCHEME. We rely on string-index to skip to the + ;; next character we need to escape. We also avoid allocations + ;; wherever possible. + + ;; Given a list of integers or #f, return the sublist that + ;; starts with the lowest integer. + (define (min* x) + (let loop ((lowest x) (rest x)) + (if (null? rest) + lowest + (loop (if (or (null? lowest) (not (car lowest)) + (and (car rest) (> (car lowest) (car rest)))) rest lowest) + (cdr rest))))) + + (let ((i 0) (start 0) (len (string-length string)) + (indices (map (lambda (x) (string-index string (car x))) quotation)) + (next #f) (c #f)) + + ;; Set 'i' to the index of the next character that needs + ;; escaping, 'c' to the character that needs to be escaped, + ;; and update 'indices'. + (define (skip!) + (set! next (min* indices)) + (set! i (if (null? next) #f (car next))) + (if i + (begin + (set! c (string-ref string i)) + (set-car! next (string-index string c (+ 1 i)))) + (set! i (string-length string)))) + + (let loop () + (skip!) + (if (< i len) + (begin + (display (substring string start i) sink) + (display (cadr (assv c quotation)) sink) + (set! i (+ 1 i)) + (set! start i) + (loop)) + (display (substring string start len) sink))))) + + (let ((escape-string-s (lambda (quotation string) + (let ((sink (open-output-string))) + (escape-string quotation string sink) + (get-output-string sink))))) + (assert (equal? (escape-string-s quote-text "foo") "foo")) + (assert (equal? (escape-string-s quote-text "foo&") "foo&")) + (assert (equal? (escape-string-s quote-text "&foo") "&foo")) + (assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar")) + (assert (equal? (escape-string-s quote-text "foobar") "foo>bar"))) + + (define (escape quotation datum sink) + (cond + ((string? datum) (escape-string quotation datum sink)) + ((symbol? datum) (escape-string quotation (symbol->string datum) sink)) + ((number? datum) (display (number->string datum) sink)) + (else + (throw "Do not know how to encode" datum)))) + + (define (name->string name) + (cond + ((symbol? name) (symbol->string name)) + (else name))) + + (package + + (define (textnode string) + (lambda (sink) + (escape quote-text string sink))) + + (define (tag name . rest) + (let ((attributes (if (null? rest) '() (car rest))) + (children (if (> (length rest) 1) (cadr rest) '()))) + (lambda (sink) + (display "<" sink) + (display (name->string name) sink) + (unless (null? attributes) + (display " " sink) + (for-each (lambda (a) + (display (car a) sink) + (display "=\"" sink) + (escape quote-attribute-'' (cadr a) sink) + (display "\" " sink)) attributes)) + (if (null? children) + (display "/>\n" sink) + (begin + (display ">\n" sink) + (for-each (lambda (c) (c sink)) children) + (display "string name) sink) + (display ">\n" sink)))))) + + (define (document root . rest) + (let ((attributes (if (null? rest) '() (car rest)))) + (lambda (sink) + ;; xxx ignores attributes + (display "\n" sink) + (root sink) + (newline sink))))))) diff --git a/tests/gpgsm/Makefile.am b/tests/gpgsm/Makefile.am index 214c3b246..892d3bc8b 100644 --- a/tests/gpgsm/Makefile.am +++ b/tests/gpgsm/Makefile.am @@ -68,7 +68,7 @@ TEST_FILES = plain-1.cms.asc \ EXTRA_DIST = $(XTESTS) $(KEYS) $(CERTS) $(TEST_FILES) \ gpgsm-defs.scm run-tests.scm setup.scm -CLEANFILES = *.log +CLEANFILES = *.log report.xml # We need to depend on a couple of programs so that the tests don't # start before all programs are built. diff --git a/tests/migrations/Makefile.am b/tests/migrations/Makefile.am index e548723a7..398b15c80 100644 --- a/tests/migrations/Makefile.am +++ b/tests/migrations/Makefile.am @@ -58,7 +58,7 @@ xcheck: EXTRA_DIST = common.scm run-tests.scm setup.scm $(XTESTS) $(TEST_FILES) -CLEANFILES = *.log +CLEANFILES = *.log report.xml # We need to depend on a couple of programs so that the tests don't # start before all programs are built. diff --git a/tests/openpgp/Makefile.am b/tests/openpgp/Makefile.am index 354dff97c..a7281a5c7 100644 --- a/tests/openpgp/Makefile.am +++ b/tests/openpgp/Makefile.am @@ -259,7 +259,7 @@ CLEANFILES = prepared.stamp x y yy z out err $(data_files) \ pubring.gpg pubring.gpg~ pubring.kbx pubring.kbx~ \ secring.gpg pubring.pkr secring.skr \ gnupg-test.stop random_seed gpg-agent.log tofu.db \ - passphrases sshcontrol S.gpg-agent.ssh + passphrases sshcontrol S.gpg-agent.ssh report.xml clean-local: -rm -rf private-keys-v1.d openpgp-revocs.d tofu.d gpgtar.d