;;;; 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))))