228 lines
15 KiB
Common Lisp
228 lines
15 KiB
Common Lisp
;;;; Real pointer events on an owned Xvfb: never moves the desktop's 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) (checks 0))
|
||
(unwind-protect
|
||
(let ((number (parse-integer (read-line (uiop:process-info-output server)))))
|
||
(setf backend (lime.x11:start-lime :display-name (format nil ":~D" number)
|
||
:head-discovery :none))
|
||
(let* ((display (lime.x11::x11-backend-display backend))
|
||
(root (lime.x11::x11-backend-root backend)))
|
||
(labels ((check (truth label) (assert truth () "Pointer UI: ~A" label) (incf checks))
|
||
(session () (lime.x11::x11-backend-ui-session backend))
|
||
(overlay () (lime.x11::x11-backend-ui-overlay backend))
|
||
(hand (window label)
|
||
(check (and (= 1 (xlib/xtest:compare-cursor
|
||
display window (xlib:cursor-id (lime.x11::x11-backend-hand-cursor backend))))
|
||
(= 1 (xlib/xtest:compare-cursor display window))) label))
|
||
(arrow (label)
|
||
(check (= 1 (xlib/xtest:compare-cursor display root)) label))
|
||
(pump ()
|
||
;; Exercise the production dispatch, not duplicate routing
|
||
;; in the test. Stop once all generated events are drained.
|
||
(let ((turns 0))
|
||
(lime.x11:run-event-loop
|
||
backend :timeout 0.005
|
||
:before-event
|
||
(lambda (backend)
|
||
(assert (< (incf turns) 100) () "Event queue did not settle.")
|
||
(xlib:display-finish-output display)
|
||
(unless (xlib:event-listen display)
|
||
(setf (lime.x11::x11-backend-running-p backend) nil))))))
|
||
(move (x y)
|
||
(xlib/xtest:fake-motion-event display x y)
|
||
(pump))
|
||
(button (code)
|
||
(xlib/xtest:fake-button-event display code t)
|
||
(xlib/xtest:fake-button-event display code nil)
|
||
(pump))
|
||
(click (x y) (move x y) (button 1))
|
||
(hit (action)
|
||
(or (find action (lime.x11::x11-ui-overlay-hit-regions (overlay))
|
||
:key #'lime.x11::ui-hit-region-action :test #'equal)
|
||
(error "No hit region for ~S" action)))
|
||
(point-at (action)
|
||
(let ((hit (hit action)) (window (lime.x11::x11-ui-overlay-window (overlay))))
|
||
(move (+ (xlib:drawable-x window) (lime.x11::ui-hit-region-x hit)
|
||
(floor (lime.x11::ui-hit-region-width hit) 2))
|
||
(+ (xlib:drawable-y window) (lime.x11::ui-hit-region-y hit)
|
||
(floor (lime.x11::ui-hit-region-height hit) 2)))))
|
||
(activate (action) (point-at action) (button 1))
|
||
(key (key) (activate (list :key key))))
|
||
(pump)
|
||
(check (= 1 (xlib/xtest:compare-cursor
|
||
display root (xlib:cursor-id (lime.x11::x11-backend-root-cursor backend))))
|
||
"root owns the left pointer")
|
||
(move 800 600)
|
||
(check (= 1 (xlib/xtest:compare-cursor display root)) "desktop displays that cursor")
|
||
;; A client-specific cursor must still override the root default.
|
||
(let ((font (xlib:open-font display "cursor")) (cursor nil) (window nil))
|
||
(unwind-protect
|
||
(progn
|
||
(setf cursor (xlib:create-glyph-cursor
|
||
:source-font font :source-char 0 :mask-font font :mask-char 1
|
||
:foreground (xlib:make-color :red 0 :green 0 :blue 0)
|
||
:background (xlib:make-color :red 1 :green 1 :blue 1))
|
||
window (xlib:create-window :parent root :x 600 :y 450 :width 100 :height 100
|
||
:override-redirect :on :cursor cursor))
|
||
(xlib:map-window window)
|
||
(move 650 500)
|
||
(check (= 1 (xlib/xtest:compare-cursor display window)) "application cursor wins")
|
||
(check (= 0 (xlib/xtest:compare-cursor display root)) "not forcibly the root cursor"))
|
||
(when window (xlib:destroy-window window))
|
||
(when cursor (xlib:free-cursor cursor))
|
||
(xlib:close-font font)))
|
||
(let* ((bar (gethash (first (lime.x11:backend-head-ids backend))
|
||
(lime.x11::x11-backend-head-bars backend)))
|
||
(window (lime.x11::x11-head-bar-window bar))
|
||
(regions (lime.x11::x11-head-bar-hit-regions bar)))
|
||
(move 15 10)
|
||
(hand window "logo uses the hand")
|
||
(move (lime.x11::x11-head-bar-hit-region-right (first regions)) 10)
|
||
(arrow "logo delimiter uses the arrow")
|
||
(move (lime.x11::x11-head-bar-hit-region-left (second regions)) 10)
|
||
(hand window "activity tab uses the hand")
|
||
(move (lime.x11::x11-head-bar-hit-region-left (third regions)) 10)
|
||
(hand window "layout control uses the hand")
|
||
(move 500 10)
|
||
(arrow "inert title uses the arrow")
|
||
;; A widget's action may change while its text stays the same.
|
||
(let ((clickable-p t)
|
||
(action (lambda (&rest args) (declare (ignore args)))))
|
||
(lime.x11:backend-set-head-bar-status-providers
|
||
backend (list (lambda (backend head-id)
|
||
(declare (ignore backend head-id))
|
||
(lime.x11:make-head-bar-segment :text "Music"
|
||
:click-action (and clickable-p action)))))
|
||
(let* ((region (car (last (lime.x11::x11-head-bar-hit-regions bar))))
|
||
(x (floor (+ (lime.x11::x11-head-bar-hit-region-left region)
|
||
(lime.x11::x11-head-bar-hit-region-right region)) 2)))
|
||
(move x 10)
|
||
(hand window "clickable status uses the hand")
|
||
(setf clickable-p nil)
|
||
(lime.x11::render-head-bars backend)
|
||
(pump)
|
||
(arrow "inert widget restores arrow without pointer movement")
|
||
(setf clickable-p t)
|
||
(lime.x11::render-head-bars backend)
|
||
(pump)
|
||
(hand window "new widget action restores hand without movement"))
|
||
(lime.x11:backend-set-head-bar-status-providers backend nil)
|
||
(pump)
|
||
(arrow "removed widget restores arrow"))
|
||
(move 15 10)
|
||
(hand window "hand restored on bar re-entry")
|
||
(move 800 600)
|
||
(arrow "leaving the bar restores desktop arrow"))
|
||
;; Start at the actual bar button, then navigate entirely by mouse.
|
||
(click 15 10)
|
||
(check (and (session) (eq :key-path (lime.ui:ui-session-mode (session)))) "logo opens menu")
|
||
(point-at '(:key #\w))
|
||
(check (equal '(:key #\w) (lime.x11::x11-ui-overlay-hovered-action (overlay))) "entry hovers")
|
||
(hand (lime.x11::x11-ui-overlay-window (overlay)) "menu entry uses the hand")
|
||
(button 1)
|
||
(check (string= "Lime › w Windows" (lime.x11::%ui-menu-heading (session))) "click enters submenu")
|
||
(key :backspace)
|
||
(check (null (lime.ui:ui-session-key-path (session))) "Back goes up")
|
||
(key :tab)
|
||
(check (eq :search (lime.ui:ui-session-mode (session))) "Search button works")
|
||
(key :tab)
|
||
(check (eq :key-path (lime.ui:ui-session-mode (session))) "Menu returns to root")
|
||
(let ((mode (lime.ui:ui-session-mode (session))))
|
||
(click 1 23)
|
||
(check (eq mode (lime.ui:ui-session-mode (session))) "blank overlay space is inert")
|
||
(arrow "blank menu space uses the arrow"))
|
||
(key #\v)
|
||
(key #\s)
|
||
(check (eq :prompt (lime.ui:ui-session-mode (session))) "click opens prompt")
|
||
(key :return)
|
||
(check (string= "Input is required." (lime.ui:ui-session-status (session))) "Confirm validates input")
|
||
(lime.ui:ui-session-handle-key (session) #\M)
|
||
(lime.x11::%render-command-palette backend)
|
||
(key :return)
|
||
(check (not (session)) "Confirm saves and closes")
|
||
(check (getf (lime.x11:backend-status backend) :source-view-id) "checkpoint was saved")
|
||
(click 15 10)
|
||
(key #\v)
|
||
(key #\o)
|
||
(check (eq :search (lime.ui:ui-session-mode (session))) "click opens scoped picker")
|
||
(activate (list :candidate (first (lime.ui:ui-session-candidates (session)))))
|
||
(check (not (session)) "click picks saved View")
|
||
;; Result replacement, wheel selection, stale regions, and errors.
|
||
(let* ((runs 0)
|
||
(choice (lime.ui:make-ui-candidate
|
||
:label "Take this choice" :action (lambda () (incf runs) (lime.ui:ui-close-result))))
|
||
(bad (lime.ui:make-ui-candidate :label "Fail safely" :action (lambda () (error "Test failure"))))
|
||
(picker (lime.ui:make-ui-candidate
|
||
:label "Choices" :action (lambda () (lime.ui:ui-replace-result (list choice bad))))))
|
||
(lime.x11::%open-ui-session backend (lime.ui:make-ui-session (list picker)))
|
||
(point-at (list :candidate picker))
|
||
(hand (lime.x11::x11-ui-overlay-window (overlay)) "search result uses the hand")
|
||
(lime.ui:ui-session-handle-key (session) #\z)
|
||
(lime.x11::%render-command-palette backend)
|
||
(pump)
|
||
(arrow "no matches restores arrow without movement")
|
||
(check (null (lime.x11::x11-ui-overlay-hovered-action (overlay))) "no stale result highlight")
|
||
(lime.ui:ui-session-handle-key (session) :backspace)
|
||
(lime.x11::%render-command-palette backend)
|
||
(pump)
|
||
(hand (lime.x11::x11-ui-overlay-window (overlay)) "restored results restore hand without movement")
|
||
(activate (list :candidate picker))
|
||
(check (equal (list choice bad) (lime.ui:ui-session-candidates (session))) "picker replaces choices")
|
||
(check (not (find (list :candidate picker) (lime.x11::x11-ui-overlay-hit-regions (overlay))
|
||
:key #'lime.x11::ui-hit-region-action :test #'equal)) "old hit discarded")
|
||
(button 5)
|
||
(check (= 1 (lime.ui:ui-session-selected-index (session))) "wheel moves selection")
|
||
(activate (list :candidate bad))
|
||
(check (search "Test failure" (lime.ui:ui-session-status (session))) "click errors stay in menu")
|
||
(activate (list :candidate choice))
|
||
(check (= 1 runs) "correct clicked action ran once")
|
||
(check (not (session)) "mouse choice closes"))
|
||
(let* ((head (gethash (first (lime.x11:backend-head-ids backend))
|
||
(lime.x11::x11-backend-heads backend)))
|
||
(nodes (loop for i below 40 collect
|
||
(lime.ui:make-ui-key-node :key (code-char (+ 256 i))
|
||
:label (format nil "Command ~D" i)))))
|
||
;; A non-zero Head origin checks root-to-overlay coordinate conversion.
|
||
(setf (lime.x11:x11-head-x head) 110 (lime.x11:x11-head-y head) 80
|
||
(lime.x11:x11-head-width head) 320 (lime.x11:x11-head-height head) 260)
|
||
(lime.x11::%open-ui-session backend (lime.ui:make-ui-session nil :key-path nodes :mode :key-path))
|
||
(key :page-down)
|
||
(check (= 1 (lime.ui:ui-session-key-page (session))) "next-page button")
|
||
(button 5)
|
||
(check (= 2 (lime.ui:ui-session-key-page (session))) "wheel pages grid")
|
||
(key :page-up)
|
||
(check (= 1 (lime.ui:ui-session-key-page (session))) "previous-page button")
|
||
(dolist (hit (lime.x11::x11-ui-overlay-hit-regions (overlay)))
|
||
(check (and (<= 0 (lime.x11::ui-hit-region-x hit)
|
||
(+ (lime.x11::ui-hit-region-x hit) (lime.x11::ui-hit-region-width hit)) 320)
|
||
(<= 0 (lime.x11::ui-hit-region-y hit)
|
||
(+ (lime.x11::ui-hit-region-y hit) (lime.x11::ui-hit-region-height hit))
|
||
(lime.x11::x11-ui-overlay-height (overlay)))) "clipped hit bounds"))
|
||
(point-at '(:key :escape))
|
||
(hand (lime.x11::x11-ui-overlay-window (overlay)) "offset Head's Close button uses hand")
|
||
(move 900 600)
|
||
(check (null (lime.x11::x11-ui-overlay-hovered-action (overlay))) "leaving clears hover")
|
||
(arrow "leaving menu restores arrow")
|
||
(key :escape)
|
||
(check (not (session)) "Close button works on offset Head"))
|
||
(let ((other (xlib:open-default-display (format nil ":~D" number))))
|
||
(unwind-protect
|
||
(let ((other-root (xlib:screen-root (xlib:display-default-screen other))))
|
||
(lime.x11:backend-open-command-palette backend)
|
||
(check (eq :already-grabbed (xlib:grab-keyboard other-root)) "open menu holds keyboard")
|
||
(key :escape)
|
||
(check (eq :success (xlib:grab-keyboard other-root)) "closing releases keyboard"))
|
||
(xlib:close-display other)))
|
||
(lime.x11:stop-backend backend)
|
||
(check (null (lime.x11::x11-backend-root-cursor backend)) "cursor resource released")
|
||
(check (null (lime.x11::x11-backend-hand-cursor backend)) "hand cursor released")
|
||
(format t "~&Live X11 pointer/menu: ~D checks passed.~%" checks))))
|
||
(when backend (lime.x11:stop-backend backend))
|
||
(uiop:terminate-process server)
|
||
(uiop:wait-process server)))
|