diff options
author | Maxime Devos <maximedevos@telenet.be> | 2021-01-29 22:44:30 +0100 |
---|---|---|
committer | Maxime Devos <maximedevos@telenet.be> | 2021-09-21 12:08:32 +0200 |
commit | d597b068de167b59b6692ad9744a0979c20c84b2 (patch) | |
tree | 013161f5fb0d1e3b26111f4dd75f0d1c90ef4bf3 /build-aux | |
parent | a88c43989e47c4eae843c24181fac5c18affef17 (diff) | |
download | gnunet-scheme-d597b068de167b59b6692ad9744a0979c20c84b2.tar.gz gnunet-scheme-d597b068de167b59b6692ad9744a0979c20c84b2.zip |
Write code for message handlers
Some attention was paid to the dynamic environment
in which the handlers must run (see
'call-with-interposed-environment' for some example usages).
* README.org: announce existence.
* build-aux/test-driver.scm: copy test driver from Guix.
* gnu/gnunet/util/mq-handler.scm: plenty of new procedures.
* tests/message-handlers.scm: test procedures, and various
edge cases.
Diffstat (limited to 'build-aux')
-rw-r--r-- | build-aux/test-driver.scm | 184 |
1 files changed, 184 insertions, 0 deletions
diff --git a/build-aux/test-driver.scm b/build-aux/test-driver.scm new file mode 100644 index 0000000..52af1e9 --- /dev/null +++ b/build-aux/test-driver.scm | |||
@@ -0,0 +1,184 @@ | |||
1 | ;;;; test-driver.scm - Guile test driver for Automake testsuite harness | ||
2 | |||
3 | (define script-version "2017-03-22.13") ;UTC | ||
4 | |||
5 | ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> | ||
6 | ;;; | ||
7 | ;;; This program is free software; you can redistribute it and/or modify it | ||
8 | ;;; under the terms of the GNU General Public License as published by | ||
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
10 | ;;; your option) any later version. | ||
11 | ;;; | ||
12 | ;;; This program is distributed in the hope that it will be useful, but | ||
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
15 | ;;; GNU General Public License for more details. | ||
16 | ;;; | ||
17 | ;;; You should have received a copy of the GNU General Public License | ||
18 | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
19 | |||
20 | ;;;; Commentary: | ||
21 | ;;; | ||
22 | ;;; This script provides a Guile test driver using the SRFI-64 Scheme API for | ||
23 | ;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. | ||
24 | ;;; | ||
25 | ;;;; Code: | ||
26 | |||
27 | (use-modules (ice-9 getopt-long) | ||
28 | (ice-9 pretty-print) | ||
29 | (srfi srfi-26) | ||
30 | (srfi srfi-64)) | ||
31 | |||
32 | (define (show-help) | ||
33 | (display "Usage: | ||
34 | test-driver --test-name=NAME --log-file=PATH --trs-file=PATH | ||
35 | [--expect-failure={yes|no}] [--color-tests={yes|no}] | ||
36 | [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--] | ||
37 | TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] | ||
38 | The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n")) | ||
39 | |||
40 | (define %options | ||
41 | '((test-name (value #t)) | ||
42 | (log-file (value #t)) | ||
43 | (trs-file (value #t)) | ||
44 | (color-tests (value #t)) | ||
45 | (expect-failure (value #t)) ;XXX: not implemented yet | ||
46 | (enable-hard-errors (value #t)) ;not implemented in SRFI-64 | ||
47 | (brief (value #t)) | ||
48 | (help (single-char #\h) (value #f)) | ||
49 | (version (single-char #\V) (value #f)))) | ||
50 | |||
51 | (define (option->boolean options key) | ||
52 | "Return #t if the value associated with KEY in OPTIONS is \"yes\"." | ||
53 | (and=> (option-ref options key #f) (cut string=? <> "yes"))) | ||
54 | |||
55 | (define* (test-display field value #:optional (port (current-output-port)) | ||
56 | #:key pretty?) | ||
57 | "Display \"FIELD: VALUE\\n\" on PORT." | ||
58 | (if pretty? | ||
59 | (begin | ||
60 | (format port "~A:~%" field) | ||
61 | (pretty-print value port #:per-line-prefix "+ ")) | ||
62 | (format port "~A: ~S~%" field value))) | ||
63 | |||
64 | (define* (result->string symbol #:key colorize?) | ||
65 | "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." | ||
66 | (let ((result (string-upcase (symbol->string symbol)))) | ||
67 | (if colorize? | ||
68 | (string-append (case symbol | ||
69 | ((pass) "[0;32m") ;green | ||
70 | ((xfail) "[1;32m") ;light green | ||
71 | ((skip) "[1;34m") ;blue | ||
72 | ((fail xpass) "[0;31m") ;red | ||
73 | ((error) "[0;35m")) ;magenta | ||
74 | result | ||
75 | "[m") ;no color | ||
76 | result))) | ||
77 | |||
78 | (define* (test-runner-gnu test-name #:key color? brief? out-port trs-port) | ||
79 | "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the | ||
80 | file name of the current the test. COLOR? specifies whether to use colors, | ||
81 | and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The | ||
82 | current output port is supposed to be redirected to a '.log' file." | ||
83 | |||
84 | (define (test-on-test-begin-gnu runner) | ||
85 | ;; Procedure called at the start of an individual test case, before the | ||
86 | ;; test expression (and expected value) are evaluated. | ||
87 | (let ((result (cute assq-ref (test-result-alist runner) <>))) | ||
88 | (format #t "test-name: ~A~%" (result 'test-name)) | ||
89 | (format #t "location: ~A~%" | ||
90 | (string-append (result 'source-file) ":" | ||
91 | (number->string (result 'source-line)))) | ||
92 | (test-display "source" (result 'source-form) #:pretty? #t))) | ||
93 | |||
94 | (define (test-on-test-end-gnu runner) | ||
95 | ;; Procedure called at the end of an individual test case, when the result | ||
96 | ;; of the test is available. | ||
97 | (let* ((results (test-result-alist runner)) | ||
98 | (result? (cut assq <> results)) | ||
99 | (result (cut assq-ref results <>))) | ||
100 | (unless brief? | ||
101 | ;; Display the result of each test case on the console. | ||
102 | (format out-port "~A: ~A - ~A~%" | ||
103 | (result->string (test-result-kind runner) #:colorize? color?) | ||
104 | test-name (test-runner-test-name runner))) | ||
105 | (when (result? 'expected-value) | ||
106 | (test-display "expected-value" (result 'expected-value))) | ||
107 | (when (result? 'expected-error) | ||
108 | (test-display "expected-error" (result 'expected-error) #:pretty? #t)) | ||
109 | (when (result? 'actual-value) | ||
110 | (test-display "actual-value" (result 'actual-value))) | ||
111 | (when (result? 'actual-error) | ||
112 | (test-display "actual-error" (result 'actual-error) #:pretty? #t)) | ||
113 | (format #t "result: ~a~%" (result->string (result 'result-kind))) | ||
114 | (newline) | ||
115 | (format trs-port ":test-result: ~A ~A~%" | ||
116 | (result->string (test-result-kind runner)) | ||
117 | (test-runner-test-name runner)))) | ||
118 | |||
119 | (define (test-on-group-end-gnu runner) | ||
120 | ;; Procedure called by a 'test-end', including at the end of a test-group. | ||
121 | (let ((fail (or (positive? (test-runner-fail-count runner)) | ||
122 | (positive? (test-runner-xpass-count runner)))) | ||
123 | (skip (or (positive? (test-runner-skip-count runner)) | ||
124 | (positive? (test-runner-xfail-count runner))))) | ||
125 | ;; XXX: The global results need some refinements for XPASS. | ||
126 | (format trs-port ":global-test-result: ~A~%" | ||
127 | (if fail "FAIL" (if skip "SKIP" "PASS"))) | ||
128 | (format trs-port ":recheck: ~A~%" | ||
129 | (if fail "yes" "no")) | ||
130 | (format trs-port ":copy-in-global-log: ~A~%" | ||
131 | (if (or fail skip) "yes" "no")) | ||
132 | (when brief? | ||
133 | ;; Display the global test group result on the console. | ||
134 | (format out-port "~A: ~A~%" | ||
135 | (result->string (if fail 'fail (if skip 'skip 'pass)) | ||
136 | #:colorize? color?) | ||
137 | test-name)) | ||
138 | #f)) | ||
139 | |||
140 | (let ((runner (test-runner-null))) | ||
141 | (test-runner-on-test-begin! runner test-on-test-begin-gnu) | ||
142 | (test-runner-on-test-end! runner test-on-test-end-gnu) | ||
143 | (test-runner-on-group-end! runner test-on-group-end-gnu) | ||
144 | (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) | ||
145 | runner)) | ||
146 | |||
147 | |||
148 | ;;; | ||
149 | ;;; Entry point. | ||
150 | ;;; | ||
151 | |||
152 | (define (main . args) | ||
153 | (let* ((opts (getopt-long (command-line) %options)) | ||
154 | (option (cut option-ref opts <> <>))) | ||
155 | (cond | ||
156 | ((option 'help #f) (show-help)) | ||
157 | ((option 'version #f) (format #t "test-driver.scm ~A" script-version)) | ||
158 | (else | ||
159 | (let ((log (open-file (option 'log-file "") "w0")) | ||
160 | (trs (open-file (option 'trs-file "") "wl")) | ||
161 | (out (duplicate-port (current-output-port) "wl"))) | ||
162 | (redirect-port log (current-output-port)) | ||
163 | (redirect-port log (current-warning-port)) | ||
164 | (redirect-port log (current-error-port)) | ||
165 | (test-with-runner | ||
166 | (test-runner-gnu (option 'test-name #f) | ||
167 | #:color? (option->boolean opts 'color-tests) | ||
168 | #:brief? (option->boolean opts 'brief) | ||
169 | #:out-port out #:trs-port trs) | ||
170 | (load-from-path (option 'test-name #f))) | ||
171 | (close-port log) | ||
172 | (close-port trs) | ||
173 | (close-port out)))) | ||
174 | (exit 0))) | ||
175 | |||
176 | ;;; Local Variables: | ||
177 | ;;; eval: (add-hook 'write-file-functions 'time-stamp) | ||
178 | ;;; time-stamp-start: "(define script-version \"" | ||
179 | ;;; time-stamp-format: "%:y-%02m-%02d.%02H" | ||
180 | ;;; time-stamp-time-zone: "UTC" | ||
181 | ;;; time-stamp-end: "\") ;UTC" | ||
182 | ;;; End: | ||
183 | |||
184 | ;;;; test-driver.scm ends here. | ||