From 6539df471196ce8941dbef6256f867bfe9dc51e2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 8 Oct 2026 07:08:51 -0400 Subject: [PATCH] Run a window manager under xvfb-run Tests listed in test-xvfb-paths ran on a bare Xvfb display, where no window ever gets the focus. Many GUI tests assume that a window manager focuses a newly shown frame, as metacity does on the shared display, so they failed or hung under xvfb-run. xvfb-run now runs the new with-wm.sh, which starts the window manager from fluxbox-path on the new display, waits a second for it to take over the screen, runs the test, and exits with the test's status. The shared display and with-wm.sh take the window manager's arguments from one definition. The xvfb tests now use fixture files in tests/xvfb instead of writing programs from strings, and a new test checks that a frame shown under xvfb-run gets the focus. --- plt-build.rkt | 108 +++++++++++++++++------------------ tests/xvfb/focus.rkt | 14 +++++ tests/xvfb/gui-test.rkt | 2 + tests/xvfb/info.rkt | 6 ++ tests/xvfb/other.rkt | 2 + tests/xvfb/print-display.rkt | 3 + tests/xvfb/tests/visual.rkt | 2 + with-wm.sh | 32 +++++++++++ 8 files changed, 114 insertions(+), 55 deletions(-) create mode 100644 tests/xvfb/focus.rkt create mode 100644 tests/xvfb/gui-test.rkt create mode 100644 tests/xvfb/info.rkt create mode 100644 tests/xvfb/other.rkt create mode 100644 tests/xvfb/print-display.rkt create mode 100644 tests/xvfb/tests/visual.rkt create mode 100755 with-wm.sh diff --git a/plt-build.rkt b/plt-build.rkt index 39eb8de..978ea9c 100644 --- a/plt-build.rkt +++ b/plt-build.rkt @@ -53,9 +53,16 @@ (and (path? base) (hash-ref xvfb-paths base #f)))))) +;; Arguments for the window manager at (fluxbox-path), after any display argument +(define wm-args '("--sm-disable" "--compositor=none")) + +;; Runs a command under a window manager; see the script for details +(define-runtime-path with-wm-path "with-wm.sh") + ;; Given a test file path, trunk directory, and command, returns ;; (values display-string final-cmd) where display-string is "" when ;; xvfb-run wraps the command, or the given fallback-display otherwise. +;; Under xvfb-run, the command runs with its own window manager. (define (maybe-wrap-xvfb pth trunk-dir cmd fallback-display) (define needs-xvfb (path-needs-xvfb? pth trunk-dir)) (if needs-xvfb @@ -63,7 +70,12 @@ (list* "/usr/bin/xvfb-run" "--auto-servernum" "--server-args=-screen 0 1024x768x24" - cmd)) + (if (fluxbox-path) + (append (list (bash-path) (path->string with-wm-path) (fluxbox-path)) + wm-args + (list "--") + cmd) + cmd))) (values fallback-display cmd))) (define current-env (make-parameter (make-immutable-hash empty))) @@ -551,9 +563,7 @@ (notify! "Starting WM #~a" i) (with-running-program (fluxbox-path) - (list "-d" (format ":~a" i) - "--sm-disable" - "--compositor=none") + (list* "-d" (format ":~a" i) wm-args) inner))))) (start-x-server @@ -572,81 +582,62 @@ [integrate-revision (exact-nonnegative-integer? . -> . void)]) (module+ test - (require rackunit racket/file "status.rkt") - - ;; Set up a temporary package directory with info.rkt that defines test-xvfb-paths - (define tmp (make-temporary-file "xvfb-test-~a" 'directory)) - (define sub (build-path tmp "tests")) - (make-directory* sub) - - ;; Create info.rkt listing one file and one directory - (display-to-file - "#lang info\n(define test-xvfb-paths '(\"gui-test.rkt\" \"tests\"))\n" - (build-path tmp "info.rkt")) + (require rackunit "status.rkt") - ;; Create the files so paths resolve - (display-to-file "" (build-path tmp "gui-test.rkt")) - (display-to-file "" (build-path tmp "other.rkt")) - (display-to-file "" (build-path sub "visual.rkt")) + ;; tests/xvfb/info.rkt lists gui-test.rkt, print-display.rkt, focus.rkt, + ;; and the tests directory in test-xvfb-paths + (define-runtime-path xvfb-dir "tests/xvfb") ;; Clear caches from any prior test run (hash-clear! xvfb-paths) (hash-clear! xvfb-info-done) ;; File listed directly should match - (check-true (and (path-needs-xvfb? (build-path tmp "gui-test.rkt") tmp) #t)) + (check-true (and (path-needs-xvfb? (build-path xvfb-dir "gui-test.rkt") xvfb-dir) #t)) ;; File under a listed directory should match - (check-true (and (path-needs-xvfb? (build-path sub "visual.rkt") tmp) #t)) + (check-true (and (path-needs-xvfb? (build-path xvfb-dir "tests" "visual.rkt") xvfb-dir) #t)) ;; File not listed should not match - (check-false (path-needs-xvfb? (build-path tmp "other.rkt") tmp)) + (check-false (path-needs-xvfb? (build-path xvfb-dir "other.rkt") xvfb-dir)) - (delete-directory/files tmp) - - ;; Integration test: maybe-wrap-xvfb drives xvfb-run wrapping of the command + ;; Integration tests: maybe-wrap-xvfb drives xvfb-run wrapping of the command ;; Find raco next to the currently running racket binary (define raco-path (build-path (path-only (find-system-path 'exec-file)) "raco")) - (define tmp2 (make-temporary-file "xvfb-int-~a" 'directory)) - - (display-to-file - "#lang info\n(define test-xvfb-paths '(\"print-display.rkt\"))\n" - (build-path tmp2 "info.rkt")) - - (display-to-file - "#lang racket/base\n(displayln (getenv \"DISPLAY\"))\n" - (build-path tmp2 "print-display.rkt")) - - (hash-clear! xvfb-paths) - (hash-clear! xvfb-info-done) - - (define test-pth (build-path tmp2 "print-display.rkt")) - - ;; Build cmd the same way production code does: raco test - (define cmd (list (path->string raco-path) - "test" (path->string test-pth))) - - ;; Call the same function the production code calls - (define-values (display-str final-cmd) - (maybe-wrap-xvfb test-pth tmp2 cmd ":20")) - - ;; Should have chosen xvfb-run - (check-equal? display-str "") - (check-equal? (first final-cmd) "/usr/bin/xvfb-run") - - (define result + ;; A window manager for the wrapped commands, or #f if none is installed + (define wm + (for/first ([p (in-list (list (fluxbox-path) "metacity" "fluxbox"))] + #:when p + [found (in-value (find-executable-path p))] + #:when found) + (path->string found))) + + ;; Runs `raco test` on the named file in tests/xvfb, 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-values (display-str final-cmd) + (parameterize ([fluxbox-path wm]) + (maybe-wrap-xvfb test-pth xvfb-dir cmd ":20"))) + ;; Should have chosen xvfb-run + (check-equal? display-str "") + (check-equal? (first final-cmd) "/usr/bin/xvfb-run") (run/collect/wait #:env (make-immutable-hash (list (cons "PATH" (getenv "PATH")) (cons "DISPLAY" display-str) + ;; the command inherits this process's environment, so keep + ;; GTK off any Wayland session that environment names + (cons "GDK_BACKEND" "x11") (cons "HOME" (path->string (find-system-path 'home-dir))) (cons "TMPDIR" (path->string (find-system-path 'temp-dir))))) - #:timeout 30 + #:timeout 60 (first final-cmd) (rest final-cmd))) + (define result (run-xvfb-test "print-display.rkt")) (check-pred exit? result) (check-equal? (exit-code result) 0) ;; stdout should contain a DISPLAY value like ":99" set by xvfb-run @@ -658,7 +649,14 @@ (check-true (for/or ([l (in-list stdout-lines)]) (regexp-match? #rx#"^:" l))) - (delete-directory/files tmp2)) + ;; Under xvfb-run, a window manager should focus a newly shown frame + (cond + [wm + (define focus-result (run-xvfb-test "focus.rkt")) + (check-pred exit? focus-result) + (check-equal? (exit-code focus-result) 0)] + [else + (printf "skipping the window-manager test: no window manager found\n")])) (module+ test ;; Test get-pkgs-pths: builds a fake trunk with links.rktd and checks diff --git a/tests/xvfb/focus.rkt b/tests/xvfb/focus.rkt new file mode 100644 index 0000000..4ab4c93 --- /dev/null +++ b/tests/xvfb/focus.rkt @@ -0,0 +1,14 @@ +#lang racket/base +;; Exits with 0 when a newly shown frame gets the focus within 5 seconds, +;; which happens only when a window manager runs on the display +(require racket/gui/base + racket/class) + +(define f (new frame% [label "focus"])) +(send f show #t) +(define focused? + (for/or ([i (in-range 50)]) + (sleep/yield 1/10) + (eq? f (get-top-level-focus-window)))) +(send f show #f) +(exit (if focused? 0 1)) diff --git a/tests/xvfb/gui-test.rkt b/tests/xvfb/gui-test.rkt new file mode 100644 index 0000000..b26a308 --- /dev/null +++ b/tests/xvfb/gui-test.rkt @@ -0,0 +1,2 @@ +#lang racket/base +;; Listed directly in test-xvfb-paths diff --git a/tests/xvfb/info.rkt b/tests/xvfb/info.rkt new file mode 100644 index 0000000..5fb9ba0 --- /dev/null +++ b/tests/xvfb/info.rkt @@ -0,0 +1,6 @@ +#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")) +(define test-omit-paths 'all) diff --git a/tests/xvfb/other.rkt b/tests/xvfb/other.rkt new file mode 100644 index 0000000..f761190 --- /dev/null +++ b/tests/xvfb/other.rkt @@ -0,0 +1,2 @@ +#lang racket/base +;; Not covered by test-xvfb-paths diff --git a/tests/xvfb/print-display.rkt b/tests/xvfb/print-display.rkt new file mode 100644 index 0000000..7362e09 --- /dev/null +++ b/tests/xvfb/print-display.rkt @@ -0,0 +1,3 @@ +#lang racket/base +;; Prints the display that xvfb-run chose +(displayln (getenv "DISPLAY")) diff --git a/tests/xvfb/tests/visual.rkt b/tests/xvfb/tests/visual.rkt new file mode 100644 index 0000000..ba65b51 --- /dev/null +++ b/tests/xvfb/tests/visual.rkt @@ -0,0 +1,2 @@ +#lang racket/base +;; Covered by test-xvfb-paths through its directory diff --git a/with-wm.sh b/with-wm.sh new file mode 100755 index 0000000..c1ba8c0 --- /dev/null +++ b/with-wm.sh @@ -0,0 +1,32 @@ +#!/bin/bash +# usage: with-wm.sh WM [WM-ARG ...] -- COMMAND [ARG ...] +# +# Runs COMMAND under the window manager WM on the display named by +# DISPLAY, and exits with COMMAND's status. Many GUI tests assume that a +# window manager focuses newly shown frames, as on DrDr's shared display; +# plt-build.rkt runs this script under xvfb-run so that those tests also +# work on a private Xvfb display. + +set -euo pipefail + +wm=$1 +shift +wm_args=() +while [[ $1 != "--" ]]; do + wm_args+=("$1") + shift +done +shift + +"${wm}" "${wm_args[@]}" >/dev/null 2>&1 & +wm_pid=$! + +# Give the window manager time to take over the screen before COMMAND +# shows a window. +sleep 1 + +status=0 +"$@" || status=$? + +kill "${wm_pid}" 2>/dev/null || true +exit "${status}"