Files
lime/test/x11-appearance-smoke.lisp
2026-10-02 14:14:47 -05:00

416 lines
28 KiB
Common Lisp

;;;; Opt-in real-X regression test; requires Xvfb and local Lisp dependencies.
;;;; Run from any directory: sbcl --non-interactive --load /path/to/this/file
;;;; Uses a fresh server selected by -displayfd, never the current DISPLAY.
(require :asdf)
(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
(asdf:load-system "lime/x11")
(let ((server (uiop:launch-program
'("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp")
:output :stream :error-output :interactive))
(backend nil)
(client-display nil)
(checks 0))
(unwind-protect
(let* ((number (parse-integer (read-line (uiop:process-info-output server))))
(display-name (format nil ":~D" number)))
(setf backend (lime.x11:start-lime
:display-name display-name :head-discovery :none
:config-file (asdf:system-relative-pathname
"lime" "test/x11-appearance-config.lisp"))
client-display (xlib:open-default-display display-name))
(let* ((display (lime.x11::x11-backend-display backend))
(root (lime.x11::x11-backend-root backend))
(client-root (xlib:screen-root (xlib:display-default-screen client-display)))
(windows (loop repeat 3 collect
(xlib:create-window :parent client-root :x 0 :y 0
:width 100 :height 100 :border-width 7
:background 0)))
(ids nil))
(labels ((check (truth label)
(assert truth () "Failed: ~A" label)
(incf checks))
(sync () (xlib:display-finish-output display))
(check-single-tile (window)
(sync)
(check (= 0 (xlib:drawable-border-width window)) "single tile border")
(check (= 0 (xlib:drawable-x window)) "single tile x")
(check (= 22 (xlib:drawable-y window)) "single tile keeps bar")
(check (= 1000 (xlib:drawable-width window)) "single tile width")
(check (= 600 (xlib:drawable-height window)) "single tile height"))
(drain-unmap-events ()
;; This fixture calls commands directly, without the
;; event loop. Consume real hides from monocle cycling
;; before testing a later application withdrawal.
(sync)
(loop while
(xlib:event-case (display :timeout 0 :discard-p t)
(:unmap-notify (event-window window configure-p)
(lime.x11::%handle-unmap-notify
backend event-window window configure-p)
t)
(otherwise () t))))
(pixel-at-border (window)
(sync)
(aref (xlib:image-z-pixarray
(xlib:get-image root :x (xlib:drawable-x window)
:y (+ 10 (xlib:drawable-y window))
:width 1 :height 1 :format :z-pixmap)) 0 0))
(border-is (window color)
(check (= (pixel-at-border window)
(lime.x11::%border-pixel backend color)) color)))
(xlib:display-finish-output client-display)
(xlib:change-property (first windows) :_NET_WM_NAME
(babel:string-to-octets "Already named" :encoding :utf-8)
:UTF8_STRING 8)
(xlib:display-finish-output client-display)
(dolist (window windows)
(push (lime.x11:manage-window
backend (find (xlib:window-id window) (xlib:query-tree root)
:key #'xlib:window-id)) ids)
(when (= 1 (length ids))
(check (string= "Already named"
(lime.x11:icccm-client-info-title
(lime.x11:backend-client-icccm-info backend (first ids))))
"adoption reads an existing modern title")
;; First MapRequest in the initial manual draft, then in
;; master/stack, must already be undecorated.
(check-single-tile window)
(lime.x11:backend-use-master-stack-layout backend)
(check-single-tile window)
(lime.x11:backend-use-manual-layout backend))
(when (= 2 (length ids))
(sync)
(check (= 3 (xlib:drawable-border-width (first windows)))
"second MapRequest restores first tile border")
(check (= 3 (xlib:drawable-border-width window))
"second MapRequest decorates new tile")))
(setf ids (nreverse ids))
(dolist (layout-command (list #'lime.x11:backend-use-manual-layout
#'lime.x11:backend-use-master-stack-layout))
(funcall layout-command backend)
(lime.x11:backend-hide-client backend (second ids))
(lime.x11:backend-hide-client backend (third ids))
(check-single-tile (first windows))
(lime.x11:backend-show-client
backend (third ids) :kind :float
:data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))
(check-single-tile (first windows))
(check (= 3 (xlib:drawable-border-width (third windows)))
"floating overlay keeps border above sole tile")
(lime.x11:backend-toggle-client-floating backend (third ids))
(sync)
(check (= 3 (xlib:drawable-border-width (first windows)))
"unfloating restores tiled border")
(check (= 5 (xlib:drawable-x (first windows)))
"unfloating restores outer gap")
(lime.x11:backend-hide-client backend (third ids))
(lime.x11:backend-show-client backend (second ids))
(lime.x11:backend-show-client backend (third ids)))
(lime.x11:backend-use-master-stack-layout backend)
(sync)
;; Real-font metrics, not an assumed number of pixels per glyph,
;; must position both painted controls and their click regions.
(let* ((head-id (first (lime.x11:backend-head-ids backend)))
(bar (gethash head-id (lime.x11::x11-backend-head-bars backend)))
(font (lime.x11::x11-head-bar-font bar))
(bar-window (lime.x11::x11-head-bar-window bar))
(regions (lime.x11::x11-head-bar-hit-regions bar))
(logo-right (+ 10 (lime.x11::%text-width font "Lime")))
(layout-left (+ logo-right (lime.x11::%text-width font " | ")
(lime.x11::%text-width font
(lime.x11::%bar-presentation-label backend head-id))
(lime.x11::%text-width font " | ")))
(layout-right (+ layout-left (lime.x11::%text-width font "[]=")))
(clicks 0))
(check (= logo-right (lime.x11::x11-head-bar-hit-region-right (first regions)))
"logo uses actual font width")
(check (= layout-left (lime.x11::x11-head-bar-hit-region-left (third regions)))
"layout follows measured label and separator")
(check (= layout-right (lime.x11::x11-head-bar-hit-region-right (third regions)))
"layout click width equals rendered token width")
(let* ((activity-region (second regions))
(left (lime.x11::x11-head-bar-hit-region-left activity-region))
(pixels (xlib:image-z-pixarray
(xlib:get-image bar-window :x left :y 0
:width (- (lime.x11::x11-head-bar-hit-region-right activity-region) left)
:height 22 :format :z-pixmap))))
(check (loop for i below (array-total-size pixels)
thereis (= (lime.x11::%bar-pixel bar "#ffac54") (row-major-aref pixels i)))
"active Activity text is painted in the accent color"))
(let ((pixels (xlib:image-z-pixarray
(xlib:get-image bar-window :x layout-left :y 0
:width (- layout-right layout-left)
:height 18 :format :z-pixmap))))
(check (loop for i below (array-total-size pixels)
thereis (= (lime.x11::%bar-pixel bar "#ffdbb0")
(row-major-aref pixels i)))
"layout text is painted within measured region"))
;; Inspect actual pixels, not only computed drawing positions.
(labels ((bar-pixel-at (x)
(sync)
(aref (xlib:image-z-pixarray
(xlib:get-image bar-window :x x :y 0
:width 1 :height 1 :format :z-pixmap)) 0 0))
(bar-image ()
(sync)
(xlib:image-z-pixarray
(xlib:get-image bar-window :x 0 :y 0 :width 1000 :height 22
:format :z-pixmap)))
(drain-properties ()
(xlib:display-finish-output client-display)
(sync)
(loop while
(xlib:event-case (display :timeout 0 :discard-p t)
(:property-notify (window atom)
(lime.x11::%handle-property-notify backend window atom) t)
(:unmap-notify (event-window window configure-p)
(lime.x11::%handle-unmap-notify backend event-window window configure-p) t)
(otherwise () t)))))
(let* ((title-left (+ layout-right 8))
(saved-config (lime.x11:x11-backend-configuration backend))
(alternative (lime.x11::copy-lime-configuration saved-config)))
(check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#40535d"))
"left title edge is the muted color")
(check (= (bar-pixel-at 999) (bar-pixel-at title-left))
"right title edge matches the left")
(check (= (bar-pixel-at (1+ title-left)) (lime.x11::%bar-pixel bar "#121f25"))
"title edge is exactly one pixel")
(check (= (bar-pixel-at 998) (lime.x11::%bar-pixel bar "#121f25"))
"focused title has its own background")
(setf (lime.x11::x11-backend-focused-head-id backend) nil)
(lime.x11::render-head-bars backend)
(check (= (bar-pixel-at 998) (lime.x11::%bar-pixel bar "#0b1216"))
"unfocused title background is quieter")
(check (= (bar-pixel-at 0) (lime.x11::%bar-pixel bar "#060a0c"))
"head focus does not recolor the side sections")
(setf (lime.x11::x11-backend-focused-head-id backend) head-id)
(setf (lime.x11:lime-configuration-bar-style alternative)
(lime.x11:make-head-bar-style :title-edge-color nil))
(lime.x11:apply-lime-configuration backend alternative)
(check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#121f25"))
"configuration can remove title edges live")
(lime.x11:apply-lime-configuration
backend saved-config
:source (namestring (asdf:system-relative-pathname "lime" "test/x11-appearance-config.lisp"))
:name 'cl-user::appearance-smoke-config)
(check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#40535d"))
"restoring configuration repaints title edges"))
(let* ((client (third windows))
(client-id (third ids))
(presentation (lime.core:current-presentation
(lime.x11::x11-backend-world backend) head-id))
(dirty-before (lime.core:presentation-dirty-p presentation)))
(setf (xlib:wm-name client) "Legacy title")
(drain-properties)
(check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id))
"legacy title notification refreshes the cache")
(let ((before (bar-image)))
(xlib:change-property client :_NET_WM_NAME
(babel:string-to-octets "café — Editor" :encoding :utf-8)
:UTF8_STRING 8)
(drain-properties)
(check (string= "café — Editor" (lime.x11::%bar-focused-title backend head-id))
"modern UTF-8 title wins over legacy title")
(check (not (equalp before (bar-image))) "title notification repaints actual bar pixels"))
(xlib:change-property client :_NET_WM_NAME '(255 65) :UTF8_STRING 8)
(drain-properties)
(check (find #\A (lime.x11::%bar-focused-title backend head-id))
"malformed UTF-8 does not lose the remaining title")
(xlib:change-property client :_NET_WM_NAME '(1000) :UTF8_STRING 32)
(drain-properties)
(check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id))
"wrong-format modern title falls back safely")
(xlib:change-property client :_NET_WM_NAME '(65) :STRING 8)
(drain-properties)
(check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id))
"wrong-type modern title falls back safely")
(xlib:change-property client :WM_NAME '(99 97 102 233) :STRING 8)
(xlib:change-property client :_NET_WM_NAME '() :UTF8_STRING 8)
(drain-properties)
(check (string= "café" (lime.x11::%bar-focused-title backend head-id))
"empty modern title falls back to Latin-1 legacy title")
(xlib:delete-property client :_NET_WM_NAME)
(drain-properties)
(check (string= "café" (lime.x11::%bar-focused-title backend head-id))
"deleting modern title immediately restores legacy title")
(xlib:delete-property client :_NET_WM_NAME)
(xlib:delete-property client :WM_NAME)
(xlib:set-wm-class client "editor" "ExampleEditor")
(drain-properties)
(check (string= "ExampleEditor" (lime.x11::%bar-focused-title backend head-id))
"title deletion falls back to class, not XID")
(check (eq :normal (lime.x11:icccm-client-info-wm-state
(lime.x11:backend-client-icccm-info backend client-id)))
"title updates preserve renderer WM_STATE")
(check (eql dirty-before (lime.core:presentation-dirty-p presentation))
"title refresh never dirties the draft")))
;; Check right alignment and real dispatch of segment hits.
(lime.x11:backend-set-head-bar-status-providers
backend (list (lambda (ignored-backend ignored-head)
(declare (ignore ignored-backend ignored-head))
(list (lime.x11:make-head-bar-segment
:text "Music" :click-action
(lambda (&rest ignored) (declare (ignore ignored)) (incf clicks)))
(lime.x11:make-head-bar-segment :text "20:00")))))
(sync)
(let* ((status-left (- 1000 10 (lime.x11::%text-width font "Music | 20:00")))
(status-right (+ status-left (lime.x11::%text-width font "Music")))
(region (car (last (lime.x11::x11-head-bar-hit-regions bar)))))
(check (= status-left (lime.x11::x11-head-bar-hit-region-left region))
"status right alignment uses actual font")
(check (= status-right (lime.x11::x11-head-bar-hit-region-right region))
"status click excludes separator")
(let* ((separator-width (lime.x11::%text-width font " | "))
(expected (lime.x11::%make-ui-canvas separator-width 22))
(pixels (xlib:image-z-pixarray
(xlib:get-image bar-window :x status-right :y 0
:width separator-width
:height 22 :format :z-pixmap))))
;; Thin antialiased strokes need not contain a fully opaque
;; foreground pixel. Compare the whole expected paint instead.
(unwind-protect
(progn
(lime.x11::%canvas-rectangle expected 0 0 separator-width 22 "#060a0c")
(lime.x11::%canvas-text expected font " | " 0 0 separator-width 22 "#b88755"
:baseline (lime.x11::%font-centered-baseline font 22))
(lime.x11::%cairo-flush (lime.x11::ui-canvas-surface expected))
(let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface expected)))
(stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface expected))))
(check (loop for y below 22 always
(loop for x below separator-width always
(= (aref pixels y x)
(logand #xffffff (cffi:mem-ref data :uint32
(+ (* y stride) (* x 4)))))))
"status delimiter has its own antialiased color")))
(lime.x11::%free-ui-canvas expected)))
(lime.x11::%handle-head-bar-button-press backend bar-window status-left 5 1 0 0)
(check (= 1 clicks) "status text dispatches click")
(lime.x11::%handle-head-bar-button-press backend bar-window status-right 5 1 0 0)
(check (= 1 clicks) "separator does not dispatch click"))
(lime.x11:backend-set-head-bar-status-providers backend nil)
(lime.x11:backend-focus-client backend (third ids)))
(check (= 3 (xlib:drawable-border-width (first windows))) "actual border width")
(check (= 5 (xlib:drawable-x (first windows))) "left gap")
(check (= 27 (xlib:drawable-y (first windows))) "bar and top gap")
(check (= 5 (- (xlib:drawable-x (second windows))
(+ (xlib:drawable-x (first windows))
(xlib:drawable-width (first windows)) 6))) "column gap")
(check (= 5 (- (xlib:drawable-y (third windows))
(+ (xlib:drawable-y (second windows))
(xlib:drawable-height (second windows)) 6))) "row gap")
(border-is (first windows) "#121f25")
(border-is (third windows) "#ffac54")
(lime.x11:backend-focus-client backend (first ids))
(lime.x11:backend-use-monocle-layout backend)
(sync)
(check (= 0 (xlib:drawable-border-width (first windows))) "monocle border")
(check (= 0 (xlib:drawable-x (first windows))) "monocle x")
(check (= 22 (xlib:drawable-y (first windows))) "monocle keeps bar")
(check (= 1000 (xlib:drawable-width (first windows))) "monocle width")
(check (= 600 (xlib:drawable-height (first windows))) "monocle height")
(lime.x11:backend-focus-client backend (second ids))
(sync)
(check (= 0 (xlib:drawable-border-width (second windows))) "cycled monocle border")
(lime.x11:backend-focus-client backend (first ids))
(lime.x11:backend-use-master-stack-layout backend)
(sync)
(check (= 3 (xlib:drawable-border-width (first windows))) "restore tiled border")
(check (= 5 (xlib:drawable-x (first windows))) "restore tiled gap")
(border-is (first windows) "#ffac54")
(border-is (third windows) "#121f25")
(lime.x11:backend-focus-head-background backend (first (lime.x11:backend-head-ids backend)))
(border-is (first windows) "#121f25")
(lime.x11:backend-focus-client backend (first ids))
(lime.x11:backend-set-client-fullscreen backend (first ids) t)
(sync)
(check (= 0 (xlib:drawable-border-width (first windows))) "fullscreen border")
(check (= 0 (xlib:drawable-x (first windows))) "fullscreen x")
(check (= 0 (xlib:drawable-y (first windows))) "fullscreen y")
(check (= 1000 (xlib:drawable-width (first windows))) "fullscreen width")
(check (= 622 (xlib:drawable-height (first windows))) "fullscreen height")
(lime.x11:backend-set-client-fullscreen backend (first ids) nil)
(sync)
(check (= 3 (xlib:drawable-border-width (first windows))) "restore border")
(border-is (first windows) "#ffac54")
;; Exercise a failed install after it already repainted windows.
(let* ((old (lime.x11:x11-backend-configuration backend))
(bad (lime.x11::copy-lime-configuration old))
(failed nil))
(setf (lime.x11:lime-configuration-bar-style bad)
(lime.x11:make-head-bar-style :focused-background "#112233"
:title-edge-color "#abcdef")
(lime.x11:lime-configuration-appearance bad)
(lime.x11:make-window-appearance :border-width 9
:focused-border "#123456"
:unfocused-border "#abcdef")
(lime.x11:lime-configuration-startup-hooks bad)
(list (lambda (ignored) (declare (ignore ignored))
(error "Deliberate rollback test"))))
(handler-case
(lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t)
(error () (setf failed t)))
(check failed "rollback condition")
(check (eq old (lime.x11:x11-backend-configuration backend)) "old config restored")
(sync)
(let* ((head-id (first (lime.x11:backend-head-ids backend)))
(bar (gethash head-id (lime.x11::x11-backend-head-bars backend)))
(window (lime.x11::x11-head-bar-window bar))
(pixels (xlib:image-z-pixarray
(xlib:get-image window :x 998 :y 0 :width 2 :height 1
:format :z-pixmap))))
(check (= (aref pixels 0 0) (lime.x11::%bar-pixel bar "#121f25"))
"failed config restores previous title background")
(check (= (aref pixels 0 1) (lime.x11::%bar-pixel bar "#40535d"))
"failed config restores previous title edge")
(check (null (gethash "#112233" (lime.x11::x11-head-bar-colors bar)))
"rollback releases unused bar colors"))
(check (= 3 (xlib:drawable-border-width (first windows))) "rollback geometry")
(border-is (first windows) "#ffac54")
(check (= 2 (hash-table-count (lime.x11::x11-backend-border-colors backend)))
"unused colors released"))
;; A successful install and a file reload repaint existing clients.
(let ((new (lime.x11::copy-lime-configuration
(lime.x11:x11-backend-configuration backend))))
(setf (lime.x11:lime-configuration-appearance new)
(lime.x11:make-window-appearance :border-width 2 :outer-gap 10
:inner-gap 8 :focused-border "#00ff00"))
(lime.x11:apply-lime-configuration
backend new :source (lime.x11:x11-backend-configuration-source backend)
:name (lime.x11:x11-backend-configuration-name backend))
(sync)
(check (= 2 (xlib:drawable-border-width (first windows))) "live width update")
(check (= 10 (xlib:drawable-x (first windows))) "live gap update")
(border-is (first windows) "#00ff00"))
(lime.x11:reload-backend-configuration backend)
(sync)
(check (= 3 (xlib:drawable-border-width (first windows))) "file reload border")
(check (= 5 (xlib:drawable-x (first windows))) "file reload gap")
(border-is (first windows) "#ffac54")
(lime.x11:backend-toggle-focused-client-floating
backend :data '(:x 0 :y 0 :width 1/3 :height 1/3))
(sync)
(check (= 3 (xlib:drawable-border-width (first windows))) "float border")
(check (= 0 (xlib:drawable-x (first windows))) "float no gap")
(check (= 22 (xlib:drawable-y (first windows))) "float work area")
;; Withdrawal restores app-owned width before forgetting it.
(drain-unmap-events)
(xlib:unmap-window (first windows))
(xlib:display-finish-output client-display)
(lime.x11::%handle-unmap-notify
backend root
(gethash (first ids) (lime.x11::x11-backend-client-windows backend)) nil)
(sync)
(check (= 7 (xlib:drawable-border-width (first windows))) "withdrawal original width")
(lime.x11:stop-backend backend)
(setf backend nil)
;; Roundtrip on the other connection after WM disconnect.
(xlib:display-finish-output client-display)
(dolist (window (rest windows))
(check (= 7 (xlib:drawable-border-width window)) "shutdown original width"))
(format t "~&Live X11 appearance smoke: ~D checks passed.~%" checks))))
(when backend (lime.x11:stop-backend backend))
(when client-display (xlib:close-display client-display))
(uiop:terminate-process server)
(uiop:wait-process server)))