From 9e9c4f0793ffc21ecc4c421df33de4230ebe5028 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Sep 2026 16:06:51 -0400 Subject: [PATCH] Let a package run some of its tests under a command prefix To find out why a test hangs or crashes on DrDr, it helps to run that test under a tool such as gdb or rr. Let a package ask for that in its info.rkt, the way `test-xvfb-paths` asks for Xvfb: each entry of `test-command-prefixes` pairs a relative path (a file or a directory) with a list of strings that DrDr puts before the test's `raco test` command. A test that also needs Xvfb runs the prefixed command under xvfb-run. For example, (define test-command-prefixes '(("hangs.rkt" ("/usr/bin/rr" "record")))) DrDr reads both fields from every info.rkt between the test and the trunk. When several entries cover a test, the entry for the most specific path wins. The help page documents the new field. --- plt-build.rkt | 118 +++++++++++++++++++++++------------ render.rkt | 8 +++ tests/xvfb/info.rkt | 11 ++-- tests/xvfb/print-display.rkt | 4 +- 4 files changed, 96 insertions(+), 45 deletions(-) diff --git a/plt-build.rkt b/plt-build.rkt index 2a40690..4c7ee6a 100644 --- a/plt-build.rkt +++ b/plt-build.rkt @@ -18,46 +18,74 @@ "sema.rkt" "scm.rkt") -;; test-xvfb-paths: hash of normalized-path -> #t -(define xvfb-paths (make-hash)) -(define xvfb-info-done (make-hash)) +;; What an info.rkt says about running the tests in and under its +;; directory; each field maps a normalized path (a directory path for a +;; directory) to a value: +;; xvfb: the paths in test-xvfb-paths, to #t +;; prefixes: the paths in test-command-prefixes, to their (listof string) +(struct test-info (xvfb prefixes)) (define (normalize-info-path p) (simplify-path (path->complete-path p) #f)) -(define (check-xvfb-info dir) - (define ndir (normalize-info-path dir)) - (unless (hash-ref xvfb-info-done ndir #f) - (hash-set! xvfb-info-done ndir #t) - (swallow 'check-xvfb-info dir - (lambda () - (define info (get-info/full dir)) - (when info - (define v (info 'test-xvfb-paths (lambda () '()))) - (when (list? v) - (for ([i (in-list v)]) - (when (path-string? i) - (define p (normalize-info-path (path->complete-path i dir))) - (define dp (if (directory-exists? p) - (path->directory-path p) - p)) - (hash-set! xvfb-paths dp #t))))))))) - -;; Reports whether the test at `pth` runs under xvfb-run. An info.rkt in any -;; directory from the test's own up to `trunk-dir` can list the test, or a -;; directory containing it, in test-xvfb-paths; DrDr may reach the test -;; before it reaches that info.rkt, so read them all here. -(define (path-needs-xvfb? pth trunk-dir) +;; The key for a path listed in the info.rkt of dir +(define (info-entry-key i dir) + (define p (normalize-info-path (path->complete-path i dir))) + (if (directory-exists? p) + (path->directory-path p) + p)) + +(define (read-test-info dir) + (define (entries info name) + (define v (if info (info name (lambda () '())) '())) + (if (list? v) v '())) + (swallow 'read-test-info dir + #:on-fail (lambda () (test-info (hash) (hash))) + (lambda () + (define info (get-info/full dir)) + (test-info + (for/hash ([i (in-list (entries info 'test-xvfb-paths))] + #:when (path-string? i)) + (values (info-entry-key i dir) #t)) + (for/hash ([e (in-list (entries info 'test-command-prefixes))] + #:when (match e + [(list (? path-string?) (list (? string?) ...)) #t] + [_ #f])) + (values (info-entry-key (first e) dir) (second e))))))) + +;; The test-info for dir, memoized because DrDr asks about every test in a +;; directory tree +(define test-info-cache (make-hash)) +(define (dir-test-info dir) + (hash-ref! test-info-cache (normalize-info-path dir) + (lambda () (read-test-info dir)))) + +;; The value in the `field` of some test-info for the test at `pth`, which +;; may be listed itself or through a directory containing it; the most +;; specific entry wins. An info.rkt in any directory from the test's own up +;; to `trunk-dir` can list the test. +(define (test-info-ref field pth trunk-dir) (define p (normalize-info-path pth)) (define top (path->directory-path (normalize-info-path trunk-dir))) (define rel (explode-path (find-relative-path top p))) + ;; nearest first (define ancestors - (for/list ([i (in-range (length rel))]) - (path->directory-path (apply build-path top (take rel i))))) - (for ([dir (in-list ancestors)]) - (check-xvfb-info dir)) - (for/or ([q (in-list (cons p ancestors))]) - (hash-ref xvfb-paths q #f))) + (reverse + (for/list ([i (in-range (length rel))]) + (path->directory-path (apply build-path top (take rel i)))))) + (for*/or ([q (in-list (cons p ancestors))] + [dir (in-list ancestors)]) + (hash-ref (field (dir-test-info dir)) q #f))) + +;; Reports whether the test at `pth` runs under xvfb-run +(define (path-needs-xvfb? pth trunk-dir) + (test-info-ref test-info-xvfb pth trunk-dir)) + +;; The words to put before the command for the test at `pth`, from +;; `test-command-prefixes`; xvfb-run, when the test needs it, still goes +;; first +(define (test-command-prefix pth trunk-dir) + (or (test-info-ref test-info-prefixes pth trunk-dir) '())) ;; Arguments for the window manager at (fluxbox-path), after any display argument (define wm-args '("--sm-disable" "--compositor=none")) @@ -318,7 +346,8 @@ (k (list* (raco-path cs?) rst)))])) (cond [pth-cmd - (define cmd (pth-cmd cs? (λ (x) x))) + (define cmd (append (test-command-prefix pth trunk-dir) + (pth-cmd cs? (λ (x) x)))) (define lab (vector cmd (current-seconds) #f 'submit)) (submit-job! test-workers lab @@ -591,15 +620,14 @@ (require rackunit "status.rkt") ;; tests/xvfb/info.rkt lists gui-test.rkt, print-display.rkt, focus.rkt, - ;; nested/listed.rkt, and the tests directory in test-xvfb-paths + ;; nested/listed.rkt, and the tests directory in test-xvfb-paths, and + ;; gives some of them command prefixes (define-runtime-path xvfb-dir "tests/xvfb") - ;; Checks a path with empty caches, as for the first test DrDr runs in a - ;; directory tree, so that no earlier check has read an info.rkt for it (define (needs-xvfb? . elems) - (hash-clear! xvfb-paths) - (hash-clear! xvfb-info-done) (and (path-needs-xvfb? (apply build-path xvfb-dir elems) xvfb-dir) #t)) + (define (command-prefix . elems) + (test-command-prefix (apply build-path xvfb-dir elems) xvfb-dir)) ;; File listed directly should match (check-true (needs-xvfb? "gui-test.rkt")) @@ -618,6 +646,12 @@ (check-false (needs-xvfb? "other.rkt")) (check-false (needs-xvfb? "nested" "unlisted.rkt")) + ;; Command prefixes follow the same paths, and the most specific entry wins + (check-equal? (command-prefix "gui-test.rkt") '("gdb" "--args")) + (check-equal? (command-prefix "tests" "visual.rkt") '("rr" "record")) + (check-equal? (command-prefix "tests" "deeper" "deep.rkt") '("strace" "-f")) + (check-equal? (command-prefix "other.rkt") '()) + ;; Integration tests: maybe-wrap-xvfb drives xvfb-run wrapping of the command ;; Find raco next to the currently running racket binary (define raco-path @@ -631,10 +665,12 @@ #:when found) (path->string found))) - ;; Runs `raco test` on the named file in tests/xvfb, as production code does + ;; Runs `raco test` on the named file in tests/xvfb, after the file's + ;; prefix, as production code does (define (run-xvfb-test name) (define test-pth (build-path xvfb-dir name)) - (define cmd (list (path->string raco-path) "test" (path->string test-pth))) + (define cmd (append (test-command-prefix test-pth xvfb-dir) + (list (path->string raco-path) "test" (path->string test-pth)))) (define-values (display-str final-cmd) (parameterize ([fluxbox-path wm]) (maybe-wrap-xvfb test-pth xvfb-dir cmd ":20"))) @@ -665,6 +701,8 @@ (check-true (pair? stdout-lines)) (check-true (for/or ([l (in-list stdout-lines)]) (regexp-match? #rx#"^:" l))) + ;; and the test ran under its prefix + (check-not-false (member #"prefix: yes" stdout-lines)) ;; Under xvfb-run, a window manager should focus a newly shown frame (cond diff --git a/render.rkt b/render.rkt index 52c9a8d..26d5255 100644 --- a/render.rkt +++ b/render.rkt @@ -838,6 +838,14 @@ in.} (define test-xvfb-paths '("gui-test.rkt" "tests/visual")) } + @h2{Running a test under another command} + @p{To run a test under a debugger or another tool, list it in the package's @code{info.rkt} using @code{test-command-prefixes}. Each entry pairs a relative path string (a file or a directory, as for @code{test-xvfb-paths}) with a list of strings that DrDr puts before the test's @code{raco test} command. When several entries cover a test, the entry for the most specific path wins. A test that also needs Xvfb runs the prefixed command under @code{xvfb-run}.} + @pre{ +;; in info.rkt: +(define test-command-prefixes + '(("hangs.rkt" ("/usr/bin/rr" "record")))) +} + @h1{What data is gathered during these runs?} @p{When each file is run the following is recorded: the start time, the command-line, the STDERR and STDOUT output, the exit code (unless there is a timeout), and the end time. All this information is presented in the per-file DrDr report page.} diff --git a/tests/xvfb/info.rkt b/tests/xvfb/info.rkt index 1ff82e6..b3adad8 100644 --- a/tests/xvfb/info.rkt +++ b/tests/xvfb/info.rkt @@ -1,7 +1,10 @@ #lang info -;; A fixture for plt-build.rkt's tests of test-xvfb-paths; plt-build.rkt -;; runs these files itself. -(define test-xvfb-paths - '("gui-test.rkt" "tests" "print-display.rkt" "focus.rkt" "nested/listed.rkt")) +;; A fixture for plt-build.rkt's tests of test-xvfb-paths and +;; test-command-prefixes; plt-build.rkt runs these files itself. +(define test-xvfb-paths '("gui-test.rkt" "tests" "print-display.rkt" "focus.rkt" "nested/listed.rkt")) +(define test-command-prefixes + '(("gui-test.rkt" ("gdb" "--args")) ("tests" ("rr" "record")) + ("tests/deeper" ("strace" "-f")) + ("print-display.rkt" ("/usr/bin/env" "DRDR_PREFIX=yes")))) (define test-omit-paths 'all) diff --git a/tests/xvfb/print-display.rkt b/tests/xvfb/print-display.rkt index 7362e09..0a86795 100644 --- a/tests/xvfb/print-display.rkt +++ b/tests/xvfb/print-display.rkt @@ -1,3 +1,5 @@ #lang racket/base -;; Prints the display that xvfb-run chose +;; Prints the display that xvfb-run chose, and whether the test ran under +;; its command prefix (displayln (getenv "DISPLAY")) +(printf "prefix: ~a\n" (getenv "DRDR_PREFIX"))