239 lines
16 KiB
Common Lisp
239 lines
16 KiB
Common Lisp
;;;; Floating drag correctness and hot-path regression on an owned Xvfb.
|
|
;;;; Never connects to DISPLAY or moves the user's desktop pointer.
|
|
(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))))
|
|
(name (format nil ":~D" number)))
|
|
(setf client-display (xlib:open-default-display name))
|
|
(let* ((client-root (xlib:screen-root (xlib:display-default-screen client-display)))
|
|
(windows (loop repeat 2 collect
|
|
(xlib:create-window :parent client-root :x 0 :y 0
|
|
:width 100 :height 100 :background 0))))
|
|
(dolist (window windows) (xlib:map-window window))
|
|
(xlib:display-finish-output client-display)
|
|
(setf backend (lime.x11:start-lime
|
|
:display-name name :head-discovery :none
|
|
:config-file (asdf:system-relative-pathname
|
|
"lime" "test/x11-appearance-config.lisp")))
|
|
(let* ((display (lime.x11::x11-backend-display backend))
|
|
(root (lime.x11::x11-backend-root backend))
|
|
(world (lime.x11::x11-backend-world backend))
|
|
(head (first (lime.x11:backend-head-ids backend)))
|
|
(client-id (lime.x11::%backend-client-id backend (first windows)))
|
|
(wm-window (gethash client-id (lime.x11::x11-backend-client-windows backend)))
|
|
;; Some keymaps also expose a non-modifier Super keysym;
|
|
;; use a physical key assigned to Mod4 for XTest input.
|
|
(super (first (nth-value 6 (xlib:modifier-mapping display))))
|
|
(state (xlib:make-state-mask :mod-4 :button-1)))
|
|
(labels ((check (truth label)
|
|
(assert truth () "Floating smoke: ~A" label) (incf checks))
|
|
(current () (lime.core:current-presentation world head))
|
|
(placement ()
|
|
(find client-id (lime.core:presentation-placements (current))
|
|
:key #'lime.core:placement-client-id :test #'equal))
|
|
(data () (lime.core:placement-data (placement)))
|
|
(pump ()
|
|
(let ((turns 0))
|
|
(lime.x11:run-event-loop
|
|
backend :timeout 0.001
|
|
:before-event
|
|
(lambda (backend)
|
|
(assert (< (incf turns) 2000) () "Event queue did not settle.")
|
|
(xlib:display-finish-output display)
|
|
(unless (xlib:event-listen display)
|
|
(setf (lime.x11::x11-backend-running-p backend) nil))))))
|
|
(motion (x y &optional (window wm-window) (modifiers state))
|
|
(xlib:queue-event display :motion-notify :append-p t
|
|
:window window :root root :child nil
|
|
:root-x x :root-y y :x 0 :y 0
|
|
:state modifiers :hint-p nil :same-screen-p t :time 0))
|
|
(release (button x y)
|
|
(xlib:queue-event display :button-release :append-p t
|
|
:window wm-window :root root :child nil
|
|
:root-x x :root-y y :x 0 :y 0
|
|
:state state :code button :same-screen-p t :time 0))
|
|
(start (&optional (mode :move))
|
|
(setf (lime.x11::x11-backend-pointer-drag backend)
|
|
(lime.x11::make-pointer-drag
|
|
:client-id client-id :head-id head :mode mode
|
|
:presentation-id (lime.core:presentation-id (current))
|
|
:initial-root-x 300 :initial-root-y 220
|
|
:initial-data (copy-list (data)))))
|
|
(check-pixels ()
|
|
(xlib:display-finish-output display)
|
|
(let* ((effect (lime.x11::%floating-client-configure-effect backend (current) client-id))
|
|
(geometry (lime.x11:x11-effect-geometry effect))
|
|
(window (first windows)))
|
|
(check (= (xlib:drawable-x window) (lime.core:geometry-x geometry)) "actual x")
|
|
(check (= (xlib:drawable-y window) (lime.core:geometry-y geometry)) "actual y")
|
|
(check (= (xlib:drawable-width window) (lime.core:geometry-width geometry)) "actual width")
|
|
(check (= (xlib:drawable-height window) (lime.core:geometry-height geometry)) "actual height")
|
|
(check (= 3 (xlib:drawable-border-width window)) "float retains border"))))
|
|
(lime.x11:backend-toggle-client-floating
|
|
backend client-id :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))
|
|
(lime.x11:backend-focus-client backend client-id)
|
|
(pump)
|
|
;; Actual XTest input exercises the passive grab and production routing.
|
|
(xlib/xtest:fake-motion-event display 300 220)
|
|
(xlib/xtest:fake-key-event display super t)
|
|
(xlib/xtest:fake-button-event display 1 t)
|
|
(pump)
|
|
(check (lime.x11::x11-backend-pointer-drag backend)
|
|
(format nil "Super+Button1 starts drag (key ~D, pointer ~S, float ~S, window ~D/~D)"
|
|
super (multiple-value-list (xlib:query-pointer root)) (data)
|
|
(xlib:drawable-x (first windows)) (xlib:drawable-y (first windows))))
|
|
(xlib/xtest:fake-motion-event display 400 280)
|
|
(pump)
|
|
(check (= 7/20 (getf (data) :x)) "real drag moves 100 pixels horizontally")
|
|
(check (= 7/20 (getf (data) :y)) "real drag moves 60 pixels vertically")
|
|
(xlib/xtest:fake-button-event display 1 nil)
|
|
(xlib/xtest:fake-key-event display super nil)
|
|
(pump)
|
|
(check (null (lime.x11::x11-backend-pointer-drag backend)) "real release ends drag")
|
|
(check-pixels)
|
|
;; A large motion burst uses a bounded number of geometry updates,
|
|
;; with no desktop reconciliation, refocus, or root property writes.
|
|
(lime.x11:backend-set-client-floating-geometry backend client-id :x 1/4 :y 1/4)
|
|
(lime.x11:backend-save-view backend "drag-start" "Before dragging")
|
|
(lime.x11:backend-activate-view backend "drag-start")
|
|
(pump)
|
|
(start)
|
|
(let ((updates 0) (bars 0) (syncs 0) (focuses 0)
|
|
(execute (symbol-function 'lime.x11::%execute-x11-effect))
|
|
(draw (symbol-function 'lime.x11::render-head-bars))
|
|
(sync (symbol-function 'lime.x11::ewmh-sync-client-lists))
|
|
(focus (symbol-function 'lime.x11::icccm-focus-client)))
|
|
(unwind-protect
|
|
(progn
|
|
(setf (symbol-function 'lime.x11::%execute-x11-effect)
|
|
(lambda (backend effect)
|
|
(incf updates)
|
|
(check (and (eq :configure (lime.x11:x11-effect-kind effect))
|
|
(equal client-id (lime.x11:x11-effect-client-id effect)))
|
|
"drag only configures its own client")
|
|
(funcall execute backend effect))
|
|
(symbol-function 'lime.x11::render-head-bars)
|
|
(lambda (backend) (incf bars) (funcall draw backend))
|
|
(symbol-function 'lime.x11::ewmh-sync-client-lists)
|
|
(lambda (backend) (incf syncs) (funcall sync backend))
|
|
(symbol-function 'lime.x11::icccm-focus-client)
|
|
(lambda (&rest args) (incf focuses) (apply focus args)))
|
|
(loop for i from 1 to 600 do (motion (+ 300 (mod i 151)) 280))
|
|
;; Release has a newer position than the final motion.
|
|
(release 1 450 310)
|
|
;; Must not coalesce a later event backward across release.
|
|
(motion 900 600)
|
|
(pump)
|
|
(check (<= 2 updates 4) "600 queued motions collapse into bounded batches")
|
|
(check (= 1 bars) "only the clean-to-dirty transition redraws bars")
|
|
(check (zerop syncs) "no EWMH list refresh during motion")
|
|
(check (zerop focuses) "no focus renegotiation during motion")
|
|
(check (= 2/5 (getf (data) :x)) "release's final x wins")
|
|
(check (= 2/5 (getf (data) :y)) "release's final y wins")
|
|
(check (null (lime.x11::x11-backend-pointer-drag backend)) "queued release ends drag")
|
|
(format t "~&600-motion burst: ~D geometry updates, ~D bar redraw, ~D list syncs, ~D refocuses.~%"
|
|
updates bars syncs focuses))
|
|
(setf (symbol-function 'lime.x11::%execute-x11-effect) execute
|
|
(symbol-function 'lime.x11::render-head-bars) draw
|
|
(symbol-function 'lime.x11::ewmh-sync-client-lists) sync
|
|
(symbol-function 'lime.x11::icccm-focus-client) focus)))
|
|
(check-pixels)
|
|
(check (lime.core:validate-world world) "world invariants after burst")
|
|
;; Saved checkpoints retain their original geometry until updated.
|
|
(lime.x11:backend-activate-view backend "drag-start")
|
|
(check (= 1/4 (getf (data) :x)) "checkpoint geometry was not mutated")
|
|
(pump)
|
|
(start)
|
|
(let ((revision (lime.core:world-revision world)))
|
|
(lime.x11::%handle-motion-notify backend 300 220 state)
|
|
(check (= revision (lime.core:world-revision world)) "stationary motion is a no-op")
|
|
(check (not (lime.core:presentation-dirty-p (current))) "stationary click stays clean"))
|
|
;; Resize shares the light path and still honors client increments.
|
|
(setf (xlib:wm-normal-hints (first windows))
|
|
(xlib:make-wm-size-hints :min-width 80 :min-height 60
|
|
:width-inc 8 :height-inc 10))
|
|
(xlib:display-finish-output client-display)
|
|
(pump)
|
|
(start :resize)
|
|
(motion 350 250)
|
|
(release 1 355 255)
|
|
(pump)
|
|
(check (lime.x11::x11-backend-pointer-drag backend) "unrelated release does not end resize")
|
|
(release 3 360 260)
|
|
(pump)
|
|
(check (= 14/25 (getf (data) :width)) "resize ends at release width")
|
|
(check (= 17/30 (getf (data) :height)) "resize ends at release height")
|
|
(check-pixels)
|
|
(check (zerop (mod (xlib:drawable-width (first windows)) 8)) "resize respects width increments")
|
|
(check (zerop (mod (xlib:drawable-height (first windows)) 10)) "resize respects height increments")
|
|
;; Report, rather than assert, wall-clock timing: the stable
|
|
;; regression above asserts protocol work, not machine speed.
|
|
(lime.x11:backend-set-client-floating-geometry
|
|
backend client-id :x 1/4 :y 1/4 :width 1/2 :height 1/2)
|
|
(flet ((measure (function)
|
|
(xlib:display-finish-output display)
|
|
(let ((start (get-internal-real-time)))
|
|
(dotimes (i 120) (funcall function (/ (+ 200 i) 1000)))
|
|
(xlib:display-finish-output display)
|
|
(/ (- (get-internal-real-time) start)
|
|
(float internal-time-units-per-second)))))
|
|
(let* ((full (measure
|
|
(lambda (x)
|
|
(lime.core:set-client-floating-geometry
|
|
world (lime.core:presentation-id (current)) client-id :x x)
|
|
(lime.x11:apply-active-presentation backend))))
|
|
(delta (measure
|
|
(lambda (x)
|
|
(lime.x11:backend-set-client-floating-geometry backend client-id :x x)))))
|
|
(format t "~&120 uncoalesced geometry edits: full desktop ~,3Fs; geometry-only ~,3Fs.~%"
|
|
full delta)))
|
|
(pump)
|
|
;; Commands/lifecycle events are coalescing boundaries, not discarded.
|
|
(start)
|
|
(motion 310 230)
|
|
(xlib:queue-event display :key-press :append-p t :window root :root root
|
|
:child nil :root-x 0 :root-y 0 :x 0 :y 0 :state 0
|
|
:code super :same-screen-p t :time 0)
|
|
(motion 320 240)
|
|
(multiple-value-bind (x y)
|
|
(lime.x11::%coalesce-drag-motion backend wm-window 300 220 state)
|
|
(check (and (= x 310) (= y 230)) "coalescing stops before key press"))
|
|
(check (eq :key-press
|
|
(xlib:event-case (display :timeout 0)
|
|
(:key-press () :key-press) (otherwise () :unexpected)))
|
|
"key press remains in queue")
|
|
(pump)
|
|
(start)
|
|
(let ((old (current)))
|
|
(lime.x11:backend-start-activity backend "other" "Other")
|
|
(let ((revision (lime.core:world-revision world)))
|
|
(lime.x11::%handle-motion-notify backend 500 400 state)
|
|
(check (= revision (lime.core:world-revision world)) "switching draft invalidates gesture")
|
|
(check (null (lime.x11::x11-backend-pointer-drag backend)) "stale draft drag cancelled"))
|
|
(lime.x11:backend-activate-activity backend (lime.core:presentation-activity-id old)))
|
|
(pump)
|
|
(start)
|
|
(lime.x11:backend-toggle-client-floating backend client-id)
|
|
(lime.x11::%handle-motion-notify backend 500 400 state)
|
|
(check (null (lime.x11::x11-backend-pointer-drag backend)) "unfloating cancels gesture")
|
|
(lime.x11:backend-toggle-client-floating backend client-id)
|
|
(start)
|
|
(xlib:destroy-window (first windows))
|
|
(xlib:display-finish-output client-display)
|
|
(pump)
|
|
(check (null (lime.x11::x11-backend-pointer-drag backend)) "destroyed client cancels gesture")
|
|
(check (lime.core:validate-world world) "world invariants after destruction")
|
|
(check (null (lime.x11::x11-backend-last-command-error backend)) "no swallowed drag errors")
|
|
(format t "~&Live X11 floating: ~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)))
|