[Pkg-gnupg-commit] [gnupg2] 88/132: gpgscm: Emit JUnit-style XML reports.
Daniel Kahn Gillmor
dkg at fifthhorseman.net
Wed May 17 03:07:45 UTC 2017
This is an automated email from the git hooks/post-receive script.
dkg pushed a commit to branch experimental
in repository gnupg2.
commit ee715201ae784e840b6136393289e6dbd6f4c540
Author: Justus Winter <justus at g10code.com>
Date: Tue Apr 18 18:51:06 2017 +0200
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 <justus at g10code.com>
---
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(-)
diff --git a/tests/gpgme/Makefile.am b/tests/gpgme/Makefile.am
index daf7572..37485e7 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 dc999fb..1bdd373 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 cafca8d..258f692 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 5e04d97..e4b535e 100644
--- a/tests/gpgscm/main.c
+++ b/tests/gpgscm/main.c
@@ -313,6 +313,8 @@ main (int argc, char **argv)
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)
err = load (sc, "gnupg.scm", 0, 1);
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index b2dcc54..3118977 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 0000000..771ec36
--- /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 <http://www.gnu.org/licenses/>.
+
+(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 "foo<bar") "foo<bar"))
+ (assert (equal? (escape-string-s quote-text "foo>bar") "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 "</" sink)
+ (display (name->string name) sink)
+ (display ">\n" sink))))))
+
+ (define (document root . rest)
+ (let ((attributes (if (null? rest) '() (car rest))))
+ (lambda (sink)
+ ;; xxx ignores attributes
+ (display "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" sink)
+ (root sink)
+ (newline sink)))))))
diff --git a/tests/gpgsm/Makefile.am b/tests/gpgsm/Makefile.am
index 214c3b2..892d3bc 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 e548723..398b15c 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 354dff9..a7281a5 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
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git
More information about the Pkg-gnupg-commit
mailing list