234 lines
16 KiB
Common Lisp
234 lines
16 KiB
Common Lisp
;;;; Real ICCCM/EWMH events on an owned Xvfb; never touches the user's DISPLAY.
|
|
(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" "1200x600x24" "-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)))
|
|
(setf backend (lime.x11:start-lime
|
|
:display-name display-name :install-default-keybindings-p nil
|
|
:heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 600 :height 600)
|
|
(lime.x11:make-x11-head :head-id "right" :x 600 :y 0 :width 600 :height 600)))
|
|
clients (xlib:open-default-display display-name))
|
|
(let* ((display (lime.x11::x11-backend-display backend))
|
|
(root (xlib:screen-root (xlib:display-default-screen clients)))
|
|
(a (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100))
|
|
(b (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100))
|
|
(aid nil) (bid nil))
|
|
(labels ((check (truth label) (assert truth () "Attention: ~A" label) (incf checks))
|
|
(world () (lime.x11:x11-backend-world backend))
|
|
(current (head) (lime.core:current-presentation (world) head))
|
|
(needs (id) (lime.x11:backend-client-needs-attention-p backend id))
|
|
(focused () (xlib:window-id (xlib:input-focus clients)))
|
|
(pump ()
|
|
(xlib:display-finish-output clients)
|
|
(let ((turns 0))
|
|
(lime.x11:run-event-loop
|
|
backend :timeout 0.005
|
|
:before-event
|
|
(lambda (b)
|
|
(assert (< (incf turns) 400) () "Attention event queue did not settle.")
|
|
(xlib:display-finish-output display)
|
|
(unless (xlib:event-listen display)
|
|
(setf (lime.x11::x11-backend-running-p b) nil))))))
|
|
(hints (w urgent &optional (input 1))
|
|
(xlib:change-property w :WM_HINTS (list (+ 3 (if urgent 256 0)) input 1 0 0 0 0 0 0) :WM_HINTS 32)
|
|
(pump))
|
|
(state (w action &optional (first :_NET_WM_STATE_DEMANDS_ATTENTION) second)
|
|
(xlib:send-event root :client-message '(:substructure-redirect :substructure-notify)
|
|
:window w :type :_NET_WM_STATE :format 32
|
|
:data (list action (xlib:intern-atom clients first)
|
|
(if second (xlib:intern-atom clients second) 0) 1 0))
|
|
(pump))
|
|
(atoms (w) (xlib:get-property w :_NET_WM_STATE :type :ATOM))
|
|
(has-atom (w name) (member (xlib:intern-atom clients name) (atoms w)))
|
|
(key (key) (lime.x11::%perform-ui-action backend (list :key key)) (pump))
|
|
(visit (id)
|
|
(lime.x11:backend-open-attention-picker backend)
|
|
(let ((candidate (find (list :attend-client id)
|
|
(lime.ui:ui-session-candidates (lime.x11::x11-backend-ui-session backend))
|
|
:key #'lime.ui:ui-candidate-id :test #'equal)))
|
|
(check candidate "visit target appears in picker")
|
|
(lime.x11::%perform-ui-action backend (list :candidate candidate)))
|
|
(pump))
|
|
(adopt (w)
|
|
(xlib:display-finish-output clients)
|
|
(prog1 (lime.x11:manage-window backend (xlib::lookup-window display (xlib:window-id w)))
|
|
(pump))))
|
|
(lime.x11:backend-start-activity backend "work" "Work")
|
|
(xlib:change-property a :_NET_WM_NAME (babel:string-to-octets "Urgent 日本語" :encoding :utf-8) :UTF8_STRING 8)
|
|
(setf aid (adopt a) bid (adopt b))
|
|
(check (= (focused) (xlib:window-id b)) "new client B focused")
|
|
(check (member (xlib:intern-atom clients :_NET_WM_STATE_DEMANDS_ATTENTION)
|
|
(xlib:get-property root :_NET_SUPPORTED)) "EWMH support advertised")
|
|
(let ((snapshot (lime.persistence:snapshot-world (world))))
|
|
(hints a t)
|
|
(check (needs aid) "ICCCM urgency noticed")
|
|
(check (= (focused) (xlib:window-id b)) "urgency never steals focus")
|
|
(check (equal snapshot (lime.persistence:snapshot-world (world))) "hint does not dirty or persist model state"))
|
|
(check (string= "! 1" (lime.x11:head-bar-segment-text (lime.x11::%bar-attention-segment backend))) "bar counts urgent window")
|
|
(hints b t)
|
|
(check (not (needs bid)) "already attended client acknowledged")
|
|
(check (= 3 (first (xlib:get-property b :WM_HINTS))) "only urgency bit cleared")
|
|
(check (= 1 (second (xlib:get-property b :WM_HINTS))) "InputHint preserved")
|
|
;; Two independent sources must not clear one another.
|
|
(state a 1)
|
|
(check (equal (list aid) (lime.x11:backend-attention-client-ids backend)) "deduplicated two-source count")
|
|
(state a 0)
|
|
(check (needs aid) "removing EWMH request leaves ICCCM urgency")
|
|
(hints a nil)
|
|
(check (not (needs aid)) "client cancellation clears last source")
|
|
(state a 2)
|
|
(check (needs aid) "EWMH toggle adds")
|
|
(state a 2)
|
|
(check (not (needs aid)) "EWMH toggle removes")
|
|
(state a 9)
|
|
(check (not (needs aid)) "invalid action ignored")
|
|
(state a 1 :_NET_WM_STATE_ABOVE :_NET_WM_STATE_DEMANDS_ATTENTION)
|
|
(check (needs aid) "second atom in message supported")
|
|
(state a 0)
|
|
(state a 2 :_NET_WM_STATE_DEMANDS_ATTENTION :_NET_WM_STATE_DEMANDS_ATTENTION)
|
|
(check (needs aid) "duplicate toggle applied once")
|
|
(lime.x11:backend-use-monocle-layout backend)
|
|
(pump)
|
|
(check (eq :unmapped (xlib:window-map-state a)) "non-selected monocle member stays hidden")
|
|
(check (needs aid) "monocle hiding does not acknowledge")
|
|
(visit aid)
|
|
(check (= (focused) (xlib:window-id a)) "attention visit selects monocle member")
|
|
(check (not (needs aid)) "visible monocle member acknowledged")
|
|
(lime.x11:backend-use-master-stack-layout backend)
|
|
(lime.x11:backend-focus-client backend bid :head-id "left")
|
|
(state a 1)
|
|
;; Hidden, then inactive Activity: no automatic reveal.
|
|
(lime.x11:backend-hide-client backend aid)
|
|
(pump)
|
|
(check (eq :unmapped (xlib:window-map-state a)) "urgent window can stay hidden")
|
|
(lime.x11:backend-start-activity backend "chill" "Chill")
|
|
(pump)
|
|
(check (needs aid) "inactive Activity remains discoverable")
|
|
(check (string= "Work: Urgent 日本語"
|
|
(lime.ui:ui-candidate-label (first (lime.x11::%ui-attention-candidates backend)))) "picker identifies task and live title")
|
|
;; The real bar event path opens the picker without dismissing it.
|
|
(let* ((bar (gethash "left" (lime.x11::x11-backend-head-bars backend)))
|
|
(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)))
|
|
(xlib/xtest:fake-motion-event display x 10)
|
|
(xlib/xtest:fake-button-event display 1 t)
|
|
(xlib/xtest:fake-button-event display 1 nil)
|
|
(pump)
|
|
(check (lime.x11:backend-command-palette-open-p backend) "clickable badge opens picker")
|
|
(check (needs aid) "opening picker does not acknowledge")
|
|
(key :escape)
|
|
(check (needs aid) "cancelling picker leaves parked request"))
|
|
(lime.x11:backend-open-command-palette backend)
|
|
(key #\w) (key #\a)
|
|
(check (eq :search (lime.ui:ui-session-mode (lime.x11::x11-backend-ui-session backend))) "w a enters attention search")
|
|
(key :return)
|
|
(check (not (lime.x11:backend-command-palette-open-p backend)) "visit closes picker")
|
|
(check (equal "work" (lime.core:presentation-activity-id (current "left"))) "visit returns to owning Activity")
|
|
(check (= (focused) (xlib:window-id a)) "hidden target revealed and focused")
|
|
(check (not (needs aid)) "visit acknowledges after menu grab ends")
|
|
(lime.x11:backend-set-client-fullscreen backend bid t)
|
|
(state a 1)
|
|
(visit aid)
|
|
(check (= (focused) (xlib:window-id a)) "explicit visit escapes a different fullscreen window")
|
|
(check (not (has-atom b :_NET_WM_STATE_FULLSCREEN)) "masking fullscreen exited only on user visit")
|
|
;; Actual focus matters: root background and another Head's saved
|
|
;; focus are not acknowledgement.
|
|
(lime.x11:backend-focus-head-background backend "left")
|
|
(hints a t)
|
|
(check (needs aid) "root focus does not acknowledge saved focus")
|
|
(lime.x11:backend-focus-client backend bid :head-id "left")
|
|
(lime.x11:backend-activate-activity backend "work" :head-id "right")
|
|
(lime.x11:backend-show-client-taking backend aid :head-id "right")
|
|
(lime.x11:backend-select-head backend "left")
|
|
(hints a t)
|
|
(check (needs aid) "other Head's current client stays urgent")
|
|
(let ((lease (lime.core:lease-presentation-id (lime.core:lease-for-client (world) aid))))
|
|
(visit aid)
|
|
(check (equal "right" (lime.x11::x11-backend-focused-head-id backend)) "visit follows existing Head")
|
|
(check (equal lease (lime.core:lease-presentation-id (lime.core:lease-for-client (world) aid))) "visit never transfers existing lease")
|
|
(check (not (needs aid)) "other Head visit acknowledges"))
|
|
;; Preserve unknown state and fullscreen on acknowledgement.
|
|
(lime.x11:backend-select-head backend "left")
|
|
(xlib:change-property a :_NET_WM_STATE (list (xlib:intern-atom clients :_TEST_CUSTOM_STATE)) :ATOM 32)
|
|
(state a 1 :_NET_WM_STATE_FULLSCREEN :_NET_WM_STATE_DEMANDS_ATTENTION)
|
|
;; Existing fullscreen command may select the requested Head.
|
|
;; Move back, set attention anew, then visit the fullscreen target.
|
|
(lime.x11:backend-select-head backend "left")
|
|
(state a 1)
|
|
(visit aid)
|
|
(check (has-atom a :_TEST_CUSTOM_STATE) "unknown state preserved")
|
|
(check (has-atom a :_NET_WM_STATE_FULLSCREEN) "fullscreen preserved")
|
|
(check (not (has-atom a :_NET_WM_STATE_DEMANDS_ATTENTION)) "only attention state removed")
|
|
(lime.x11:backend-set-client-fullscreen backend aid nil)
|
|
;; Globally active clients must actually answer TAKE_FOCUS.
|
|
(lime.x11:backend-select-head backend "left")
|
|
(hints a nil 0)
|
|
(setf (xlib:wm-protocols a) '(:WM_TAKE_FOCUS))
|
|
(pump)
|
|
(state a 1)
|
|
(lime.x11:backend-attend-client backend aid)
|
|
(pump)
|
|
(check (needs aid) "unanswered TAKE_FOCUS does not clear attention")
|
|
(let ((child (xlib:create-window :parent a :x 0 :y 0 :width 20 :height 20)))
|
|
(xlib:map-window child)
|
|
(xlib:set-input-focus clients child :pointer-root)
|
|
(pump)
|
|
(check (not (needs aid)) "async focus to child acknowledges owning client"))
|
|
;; Initial hints, NoInput clients, property deletion and withdrawal.
|
|
(let ((c (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100)))
|
|
(xlib:change-property c :WM_HINTS '(259 0 1 0 0 0 0 0 0) :WM_HINTS 32)
|
|
(xlib:change-property c :_NET_WM_STATE
|
|
(list (xlib:intern-atom clients :_NET_WM_STATE_DEMANDS_ATTENTION)) :ATOM 32)
|
|
(let ((cid (adopt c)))
|
|
(check (needs cid) "initial hints adopted; NoInput client not acknowledged")
|
|
(check (= 3 (gethash cid (lime.x11::x11-backend-attention-clients backend))) "both initial sources retained")
|
|
(xlib:delete-property c :WM_HINTS)
|
|
(pump)
|
|
(check (= 2 (gethash cid (lime.x11::x11-backend-attention-clients backend))) "deleted WM_HINTS clears only urgency")
|
|
(xlib:delete-property c :_NET_WM_STATE)
|
|
(pump)
|
|
(check (not (needs cid)) "deleted state clears demand")
|
|
(xlib:change-property c :_NET_WM_STATE
|
|
(list (xlib:intern-atom clients :_NET_WM_STATE_DEMANDS_ATTENTION)) :ATOM 32)
|
|
(pump)
|
|
(check (needs cid) "direct property change observed without focus")
|
|
(xlib:unmap-window c)
|
|
(pump)
|
|
(check (not (needs cid)) "withdrawal clears attention cache")
|
|
(check (null (gethash cid (lime.x11::x11-backend-client-windows backend))) "withdrawal really retires client")
|
|
(xlib:destroy-window c)
|
|
(pump)))
|
|
;; Hidden _NET_ACTIVE_WINDOW stays hidden but creates attention.
|
|
(lime.x11:backend-hide-client backend aid :head-id "right")
|
|
(xlib:send-event root :client-message '(:substructure-redirect :substructure-notify)
|
|
:window a :type :_NET_ACTIVE_WINDOW :format 32 :data '(1 0 0 0 0))
|
|
(pump)
|
|
(check (needs aid) "denied hidden activation becomes attention")
|
|
(check (eq :unmapped (xlib:window-map-state a)) "denied activation never reveals window")
|
|
;; Destroy cleans cache and an already-open stale picker stays safe.
|
|
(lime.x11:backend-open-attention-picker backend)
|
|
(xlib:destroy-window a)
|
|
(pump)
|
|
(check (not (needs aid)) "destroy clears attention")
|
|
(key :return)
|
|
(check (lime.x11:backend-command-palette-open-p backend) "stale picker stays open with explanation")
|
|
(check (null (lime.x11::x11-backend-last-command-error backend)) "no UI error after stale selection")
|
|
(key :escape)
|
|
(check (null (lime.x11:backend-attention-client-ids backend)) "no phantom attention remains")
|
|
(format t "~&Attention 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* "~&Attention smoke failed: ~A~%" condition)
|
|
(uiop:quit 1)))
|