Initial Lime window manager
This commit is contained in:
177
test/x11-cursor-smoke.lisp
Normal file
177
test/x11-cursor-smoke.lisp
Normal file
@@ -0,0 +1,177 @@
|
||||
;;;; Native cursor pixels, reload/rollback, animation, and no-RENDER fallback.
|
||||
;;;; Own Xvfb only. Adwaita, libXcursor, and test-only libXfixes are required.
|
||||
(require :asdf)
|
||||
(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
|
||||
(asdf:load-system "lime/x11")
|
||||
(cffi:load-foreign-library "libX11.so.6")
|
||||
(cffi:load-foreign-library "libXfixes.so.3")
|
||||
(cffi:defcfun ("XOpenDisplay" cursor-test-open-display) :pointer (name :string))
|
||||
(cffi:defcfun ("XCloseDisplay" cursor-test-close-display) :int (display :pointer))
|
||||
(cffi:defcfun ("XFree" cursor-test-free) :int (pointer :pointer))
|
||||
(cffi:defcfun ("XFixesGetCursorImage" cursor-test-get-image) :pointer (display :pointer))
|
||||
(cffi:defcstruct cursor-test-image
|
||||
(x :short) (y :short) (width :unsigned-short) (height :unsigned-short)
|
||||
(xhot :unsigned-short) (yhot :unsigned-short) (serial :unsigned-long)
|
||||
(pixels :pointer) (atom :unsigned-long) (name :pointer))
|
||||
|
||||
(defun cursor-test-snapshot (display)
|
||||
(let ((image (cursor-test-get-image display)))
|
||||
(assert (not (cffi:null-pointer-p image)))
|
||||
(unwind-protect
|
||||
(cffi:with-foreign-slots ((width height xhot yhot pixels) image (:struct cursor-test-image))
|
||||
(let ((copy (make-array (list height width) :element-type '(unsigned-byte 32))))
|
||||
;; Xlib's 32-bit wire pixels occupy native longs (sign-extended on LP64).
|
||||
(dotimes (i (* width height))
|
||||
(setf (row-major-aref copy i) (logand #xffffffff (cffi:mem-aref pixels :unsigned-long i))))
|
||||
(values copy xhot yhot)))
|
||||
(cursor-test-free image))))
|
||||
|
||||
(defmacro cursor-test-with-function ((name function) &body body)
|
||||
(let ((old (gensym "OLD")))
|
||||
`(let ((,old (symbol-function ',name)))
|
||||
(unwind-protect (progn (setf (symbol-function ',name) ,function) ,@body)
|
||||
(setf (symbol-function ',name) ,old)))))
|
||||
|
||||
(dolist (mode '(24 16 :no-render))
|
||||
(let ((server (uiop:launch-program
|
||||
(append (list "Xvfb" "-displayfd" "1" "-screen" "0"
|
||||
(format nil "800x600x~D" (if (integerp mode) mode 24)) "-nolisten" "tcp")
|
||||
(when (eq mode :no-render) '("-extension" "RENDER")))
|
||||
:output :stream :error-output :interactive))
|
||||
(backend nil) (probe nil) (checks 0))
|
||||
(unwind-protect
|
||||
(let* ((number (parse-integer (read-line (uiop:process-info-output server))))
|
||||
(name (format nil ":~D" number))
|
||||
(configuration (lime.x11:make-lime-configuration
|
||||
:cursor (lime.x11:make-ui-cursor-style :theme "Adwaita" :size 24))))
|
||||
(setf backend (lime.x11:start-lime :display-name name :head-discovery :none)
|
||||
probe (cursor-test-open-display name))
|
||||
(assert (not (cffi:null-pointer-p probe)))
|
||||
(let ((display (lime.x11::x11-backend-display backend)))
|
||||
(labels ((check (truth label) (assert truth () "Cursor ~A: ~A" mode label) (incf checks))
|
||||
(sync () (xlib:display-finish-output display))
|
||||
(cursor-info () (lime.x11:backend-cursor-report backend))
|
||||
(source (role) (getf (getf (cursor-info) role) :source))
|
||||
(move (x y) (xlib/xtest:fake-motion-event display x y) (sync))
|
||||
(matches (names size)
|
||||
(let ((frame (first (lime.x11::%load-cursor-frames names "Adwaita" size))))
|
||||
(multiple-value-bind (pixels x y) (cursor-test-snapshot probe)
|
||||
(check (equalp pixels (lime.x11::cursor-frame-pixels frame)) "ARGB pixels match theme file")
|
||||
(check (= x (lime.x11::cursor-frame-xhot frame)) "x hotspot")
|
||||
(check (= y (lime.x11::cursor-frame-yhot frame)) "y hotspot")))))
|
||||
(lime.x11:apply-lime-configuration backend configuration)
|
||||
;; Read actual Xresources from this isolated screen. Avoid any
|
||||
;; inherited test-runner environment hiding their precedence.
|
||||
(lime.x11::%apply-cursor-session-settings backend (lime.x11:make-ui-cursor-style))
|
||||
(let ((getenv (symbol-function 'uiop:getenv)))
|
||||
(xlib:change-property (lime.x11::x11-backend-root backend) :RESOURCE_MANAGER
|
||||
(map 'vector #'char-code (format nil "Xcursor.theme: Adwaita~%Xcursor.size: 32~%"))
|
||||
:STRING 8)
|
||||
(cursor-test-with-function
|
||||
(uiop:getenv (lambda (name)
|
||||
(unless (member name '("XCURSOR_THEME" "XCURSOR_SIZE") :test #'string=)
|
||||
(funcall getenv name))))
|
||||
(check (equal '("Adwaita" 32)
|
||||
(multiple-value-list
|
||||
(lime.x11::%backend-cursor-settings backend (lime.x11:make-ui-cursor-style))))
|
||||
"screen Xresources theme/size resolve"))
|
||||
(xlib:delete-property (lime.x11::x11-backend-root backend) :RESOURCE_MANAGER))
|
||||
(lime.x11::%apply-cursor-session-settings backend (lime.x11:lime-configuration-cursor configuration))
|
||||
(move 600 500)
|
||||
(if (eq mode :no-render)
|
||||
(progn
|
||||
(check (eq :core (source :arrow)) "arrow falls back without RENDER")
|
||||
(check (eq :core (source :hand)) "hand falls back without RENDER")
|
||||
(check (search "RENDER" (getf (getf (cursor-info) :arrow) :reason)) "fallback reason is inspectable"))
|
||||
(progn
|
||||
(check (eq :theme (source :arrow)) "arrow is themed, not silently falling back")
|
||||
(check (eq :theme (source :hand)) "hand is themed")
|
||||
(matches '("default" "left_ptr") 24)
|
||||
;; A missing requested theme can inherit the system default.
|
||||
(let ((missing (lime.x11::copy-lime-configuration configuration)))
|
||||
(setf (lime.x11:lime-configuration-cursor missing)
|
||||
(lime.x11:make-ui-cursor-style :theme "Lime-Nonexistent-Cursor-Smoke-Theme" :size 24))
|
||||
(lime.x11:apply-lime-configuration backend missing)
|
||||
(check (eq :theme (source :arrow)) "missing theme uses Xcursor's default-theme fallback"))))
|
||||
;; Core mode is always a deliberate usable escape hatch.
|
||||
(let ((core (lime.x11::copy-lime-configuration configuration)))
|
||||
(setf (lime.x11:lime-configuration-cursor core) (lime.x11:make-ui-cursor-style :theme :core))
|
||||
(lime.x11:apply-lime-configuration backend core)
|
||||
(check (eq :core (source :arrow)) "explicit core mode")
|
||||
(check (eq :core (source :hand)) "explicit core hand"))
|
||||
(unless (eq mode :no-render)
|
||||
(lime.x11:apply-lime-configuration backend configuration)
|
||||
;; Shared hand resource must be rebound even while still hovered.
|
||||
(lime.x11:backend-open-command-palette backend)
|
||||
(let* ((session (lime.x11::x11-backend-ui-session backend))
|
||||
(overlay (lime.x11::x11-backend-ui-overlay backend))
|
||||
(window (lime.x11::x11-ui-overlay-window overlay))
|
||||
(hit (first (lime.x11::x11-ui-overlay-hit-regions overlay)))
|
||||
(x (+ (xlib:drawable-x window) (lime.x11::ui-hit-region-x hit) 1))
|
||||
(y (+ (xlib:drawable-y window) (lime.x11::ui-hit-region-y hit) 1))
|
||||
(large (lime.x11::copy-lime-configuration configuration))
|
||||
(old-set (lime.x11::x11-backend-cursor-set backend)))
|
||||
(move x y)
|
||||
(lime.x11::%handle-ui-motion backend window x y)
|
||||
(sync)
|
||||
(matches '("pointer" "hand2") 24)
|
||||
(setf (lime.x11:lime-configuration-cursor large)
|
||||
(lime.x11:make-ui-cursor-style :theme "Adwaita" :size 48))
|
||||
(lime.x11:apply-lime-configuration backend large)
|
||||
(check (eq session (lime.x11::x11-backend-ui-session backend)) "live reload preserves session")
|
||||
(check (null (lime.x11::x11-cursor-set-arrow old-set)) "old resources released after commit")
|
||||
(check (= 1 (xlib/xtest:compare-cursor display window
|
||||
(xlib:cursor-id (lime.x11::x11-backend-hand-cursor backend)))) "hover rebinds new hand XID")
|
||||
(matches '("pointer" "hand2") 48)
|
||||
;; Fail after installing the replacement: restore the exact old XIDs.
|
||||
(let ((before (lime.x11::x11-backend-cursor-set backend))
|
||||
(failed-set nil) (caught nil)
|
||||
(bad (lime.x11::copy-lime-configuration configuration)))
|
||||
(setf (lime.x11:lime-configuration-startup-hooks bad)
|
||||
(list (lambda (backend)
|
||||
(setf failed-set (lime.x11::x11-backend-cursor-set backend))
|
||||
(error "Cursor rollback fixture"))))
|
||||
(handler-case (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t)
|
||||
(error () (setf caught t)))
|
||||
(check caught "later config failure is reported")
|
||||
(check (eq before (lime.x11::x11-backend-cursor-set backend)) "rollback restores original cursor set")
|
||||
(check (null (lime.x11::x11-cursor-set-hand failed-set)) "failed replacement released")
|
||||
(check (= 1 (xlib/xtest:compare-cursor display window
|
||||
(xlib:cursor-id (lime.x11::x11-backend-hand-cursor backend)))) "rollback rebinds hovered UI")
|
||||
(matches '("pointer" "hand2") 48)))
|
||||
(lime.x11:backend-close-command-palette backend)
|
||||
;; Optional-library failure does not stop the WM.
|
||||
(cursor-test-with-function (lime.x11::%ensure-cursor-library
|
||||
(lambda () (error "Library missing fixture")))
|
||||
(lime.x11:apply-lime-configuration backend configuration)
|
||||
(check (eq :core (source :arrow)) "missing library fallback")
|
||||
(check (search "Library missing" (getf (getf (cursor-info) :arrow) :reason)) "library diagnostic"))
|
||||
;; Animated themes are handed to the server, not a polling loop.
|
||||
(cursor-test-with-function
|
||||
(lime.x11::%load-cursor-frames
|
||||
(lambda (&rest args)
|
||||
(declare (ignore args))
|
||||
(values (loop for color in '(#xffff0000 #xff00ff00) collect
|
||||
(lime.x11::make-cursor-frame
|
||||
:pixels (make-array '(12 12) :element-type '(unsigned-byte 32)
|
||||
:initial-element color)
|
||||
:xhot 1 :yhot 2 :delay 20)) "fixture")))
|
||||
(lime.x11:apply-lime-configuration backend configuration)
|
||||
(check (= 2 (getf (getf (cursor-info) :arrow) :frames)) "animated arrow uploaded")
|
||||
(move 600 500)
|
||||
;; XFixes on Xvfb reports the animation wrapper's 1x1 bits,
|
||||
;; not a displayed frame. Verify the live animated XID here;
|
||||
;; static pixel/hotspot upload is checked above on both depths.
|
||||
(check (= 1 (xlib/xtest:compare-cursor
|
||||
display (lime.x11::x11-backend-root backend)
|
||||
(xlib:cursor-id (lime.x11::x11-backend-root-cursor backend))))
|
||||
"root bound to animated cursor")
|
||||
(check (= 1 (xlib/xtest:compare-cursor display (lime.x11::x11-backend-root backend)))
|
||||
"animated cursor is active")))
|
||||
(lime.x11:stop-backend backend)
|
||||
(check (null (lime.x11::x11-backend-cursor-set backend)) "shutdown clears resources")
|
||||
(format t "~&Live X11 cursor themes (~A): ~D checks passed.~%" mode checks))))
|
||||
(when backend (lime.x11:stop-backend backend))
|
||||
(when (and probe (not (cffi:null-pointer-p probe))) (cursor-test-close-display probe))
|
||||
(uiop:terminate-process server)
|
||||
(uiop:wait-process server))))
|
||||
Reference in New Issue
Block a user