Initial Lime window manager
This commit is contained in:
143
test/x11-fixed-size-smoke.lisp
Normal file
143
test/x11-fixed-size-smoke.lisp
Normal file
@@ -0,0 +1,143 @@
|
||||
;;;; Fixed-size adoption via real MapRequest/PropertyNotify on an owned Xvfb.
|
||||
;;;; Run with sbcl --non-interactive --load test/x11-fixed-size-smoke.lisp.
|
||||
;;;; Never connects to the user's DISPLAY or launches Discord itself.
|
||||
(require :asdf)
|
||||
(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
|
||||
(asdf:load-system "lime/x11")
|
||||
|
||||
(handler-case
|
||||
(let ((server (uiop:launch-program
|
||||
'("Xvfb" "-displayfd" "1" "-screen" "0" "2000x622x24" "-nolisten" "tcp")
|
||||
:output :stream :error-output :interactive))
|
||||
(backend nil) (clients nil) (checks 0))
|
||||
(unwind-protect
|
||||
(let* ((number (parse-integer (read-line (uiop:process-info-output server))))
|
||||
(display-name (format nil ":~D" number))
|
||||
(heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 1000 :height 622)
|
||||
(lime.x11:make-x11-head :head-id "right" :x 1000 :y 0 :width 1000 :height 622))))
|
||||
(setf clients (xlib:open-default-display display-name)
|
||||
backend (lime.x11:start-lime :display-name display-name :heads heads
|
||||
:install-default-keybindings-p nil))
|
||||
(setf (lime.x11::x11-backend-window-appearance backend)
|
||||
(lime.x11:make-window-appearance :border-width 3 :inner-gap 5 :outer-gap 5))
|
||||
(let ((root (xlib:screen-root (xlib:display-default-screen clients)))
|
||||
(fixed (xlib:make-wm-size-hints :min-width 300 :max-width 300
|
||||
:min-height 200 :max-height 200)))
|
||||
(labels ((check (truth label) (assert truth () "Fixed-size: ~A" label) (incf checks))
|
||||
(world () (lime.x11:x11-backend-world backend))
|
||||
(current (head) (lime.core:current-presentation (world) head))
|
||||
(id (window) (lime.x11::%backend-client-id backend window))
|
||||
(kind (window &optional (head "left"))
|
||||
(lime.core:placement-kind
|
||||
(find (id window) (lime.core:presentation-placements (current head))
|
||||
:key #'lime.core:placement-client-id :test #'equal)))
|
||||
(pump ()
|
||||
(xlib:display-finish-output clients)
|
||||
(let ((turns 0) (display (lime.x11::x11-backend-display backend)))
|
||||
(lime.x11:run-event-loop
|
||||
backend :timeout 0.005
|
||||
:before-event (lambda (b)
|
||||
(assert (< (incf turns) 400) () "Fixed-size event queue did not settle.")
|
||||
(xlib:display-finish-output display)
|
||||
(unless (xlib:event-listen display)
|
||||
(setf (lime.x11::x11-backend-running-p b) nil))))))
|
||||
(spawn (&key hints (class "discord") type parent)
|
||||
(let ((window (xlib:create-window :parent root :x 17 :y 37
|
||||
:width 300 :height 200 :background 0)))
|
||||
(xlib:set-wm-class window class class)
|
||||
(when hints (setf (xlib:wm-normal-hints window) hints))
|
||||
(when type
|
||||
(xlib:change-property window :_NET_WM_WINDOW_TYPE
|
||||
(list (xlib:intern-atom clients type)) :ATOM 32))
|
||||
(when parent
|
||||
(xlib:change-property window :WM_TRANSIENT_FOR
|
||||
(list (xlib:window-id parent)) :WINDOW 32))
|
||||
(xlib:map-window window)
|
||||
(pump)
|
||||
(check (id window) "MapRequest adopted client")
|
||||
(check (eq :viewable (xlib:window-map-state window)) "client is visible")
|
||||
window))
|
||||
(destroy (window) (xlib:destroy-window window) (pump))
|
||||
(check-full-tile (window)
|
||||
(check (equal '(0 22 1000 600 0)
|
||||
(list (xlib:drawable-x window) (xlib:drawable-y window)
|
||||
(xlib:drawable-width window) (xlib:drawable-height window)
|
||||
(xlib:drawable-border-width window)))
|
||||
"sole browser tile retains entire work area without gaps/borders")))
|
||||
(lime.x11:backend-select-head backend "left")
|
||||
(let* ((browser (spawn :class "Browser"))
|
||||
(popup (spawn :hints fixed)))
|
||||
(check (eq :tile (kind browser)) "ordinary browser is tiled")
|
||||
(check (eq :float (kind popup)) "untyped fixed-size startup window floats")
|
||||
(check (equal '(:normal) (lime.x11::ewmh-client-window-types backend (id popup)))
|
||||
"float does not depend on an EWMH splash type")
|
||||
(check-full-tile browser)
|
||||
(check (equal '(350 222 300 200 3)
|
||||
(list (xlib:drawable-x popup) (xlib:drawable-y popup)
|
||||
(xlib:drawable-width popup) (xlib:drawable-height popup)
|
||||
(xlib:drawable-border-width popup)))
|
||||
"popup preserves fixed content size, centers in work area, and keeps border")
|
||||
(check (= (xlib:window-id popup) (xlib:window-id (xlib:input-focus clients)))
|
||||
"new popup receives real X focus")
|
||||
;; The focused Head, not the global root center, owns the popup.
|
||||
(lime.x11:backend-select-head backend "right")
|
||||
(let ((other (spawn :hints fixed)))
|
||||
(check (eq :float (kind other "right")) "popup follows selected Head")
|
||||
(check (= 1350 (xlib:drawable-x other)) "right popup centers in right work area")
|
||||
(check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend (id other)))
|
||||
"popup has one lease on right Head")
|
||||
(check-full-tile browser)
|
||||
(destroy other))
|
||||
(lime.x11:backend-select-head backend "left")
|
||||
;; A user can retile it. Subsequent hints must not undo that.
|
||||
(lime.x11:backend-toggle-client-floating backend (id popup))
|
||||
(setf (xlib:wm-normal-hints popup) (xlib:make-wm-size-hints :min-width 100 :min-height 100))
|
||||
(pump)
|
||||
(check (eq :tile (kind popup)) "manual retile survives resizable hints")
|
||||
(setf (xlib:wm-normal-hints popup) fixed)
|
||||
(pump)
|
||||
(check (eq :tile (kind popup)) "later fixed hints do not reclassify existing client")
|
||||
(destroy popup)
|
||||
(check-full-tile browser)
|
||||
;; Discord's main window uses the same class but only minima.
|
||||
(let ((main (spawn :hints (xlib:make-wm-size-hints :min-width 800 :min-height 500))))
|
||||
(check (eq :tile (kind main)) "resizable Discord main window remains tiled")
|
||||
(check (< (xlib:drawable-width browser) 1000) "main window participates in master/stack")
|
||||
(destroy main))
|
||||
(check-full-tile browser)
|
||||
;; A fixed width alone is not a fixed-size client.
|
||||
(let ((one-axis (spawn :hints (xlib:make-wm-size-hints :min-width 300 :max-width 300))))
|
||||
(check (eq :tile (kind one-axis)) "one fixed axis stays tiled")
|
||||
(destroy one-axis))
|
||||
(setf (lime.x11::x11-backend-configuration backend)
|
||||
(lime.x11:make-lime-configuration :new-client-focus-p nil))
|
||||
(let ((quiet (spawn :hints fixed)))
|
||||
(check (eq :float (kind quiet)) "no-focus configuration still floats fixed window")
|
||||
(check (= (xlib:window-id browser) (xlib:window-id (xlib:input-focus clients)))
|
||||
"configured no-focus-on-new-client respected")
|
||||
(destroy quiet))
|
||||
(setf (lime.x11::x11-backend-configuration backend)
|
||||
(lime.x11:make-lime-configuration
|
||||
:rules (list (lime.x11:make-window-rule :resource-class "discord" :float-p nil))))
|
||||
(let ((forced (spawn :hints fixed))
|
||||
(splash (spawn :type :_NET_WM_WINDOW_TYPE_SPLASH)))
|
||||
(check (eq :tile (kind forced)) "explicit tiling rule overrides fixed-size default")
|
||||
(check (eq :float (kind splash)) "EWMH splash policy still wins over ordinary rules")
|
||||
(lime.x11:backend-select-head backend "right")
|
||||
(let ((transient (spawn :hints fixed :parent browser)))
|
||||
(check (eq :float (kind transient)) "transient parent policy still wins")
|
||||
(check (equal "left" (lime.x11::ewmh-active-head-id-for-client backend (id transient)))
|
||||
"transient follows parent onto left Head")
|
||||
(destroy transient))
|
||||
(destroy forced) (destroy splash))
|
||||
(check-full-tile browser)
|
||||
(check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors")
|
||||
(check (lime.core:validate-world (world)) "final world and leases valid")
|
||||
(format t "~&Fixed-size smoke: ~D checks passed.~%" checks)))))
|
||||
(when backend (ignore-errors (lime.x11:stop-backend backend)))
|
||||
(when clients (ignore-errors (xlib:close-display clients :abort t)))
|
||||
(uiop:terminate-process server)
|
||||
(uiop:wait-process server)))
|
||||
(error (condition)
|
||||
(format *error-output* "~&Fixed-size smoke failed: ~A~%" condition)
|
||||
(uiop:quit 1)))
|
||||
Reference in New Issue
Block a user