Initial Lime window manager

test/config-fixture.lisp

@@ -0,0 +1,12 @@
+(in-package #:lime.x11.test)
+
+;; This intentionally has no :OPTIONS clause: loading it proves that the DSL
+;; supplies its documented Super default without requiring a full X server.
+(lime.config:defconfiguration config-file-fixture
+  (:command reload
+   :label "Reload config"
+   :description "reload the test configuration"
+   :key #\r
+   :action (lambda (backend)
+             (declare (ignore backend))
+             :reloaded)))

test/development-package.lisp

@@ -0,0 +1,3 @@
+(defpackage #:lime.dev.test
+  (:use #:cl #:fiveam #:lime.dev)
+  (:export #:run-tests))

test/development.lisp

@@ -0,0 +1,54 @@
+(in-package #:lime.dev.test)
+
+(def-suite lime-dev-suite
+  :description "Developer runtime mailbox and reload-boundary tests.")
+
+(in-suite lime-dev-suite)
+
+(test only-ordinary-lime-systems-are-hot-reloadable
+  (is-true (lime.dev::%reloadable-development-system-p "lime"))
+  (is-true (lime.dev::%reloadable-development-system-p :lime/x11))
+  (is-false (lime.dev::%reloadable-development-system-p "lime/dev"))
+  (is-false (lime.dev::%reloadable-development-system-p "unrelated")))
+
+(test developer-start-arguments-do-not-leak-into-start-lime
+  (is (equal (lime.dev::%plist-without
+              '(:display-name ":5" :repl-port 4444 :start-repl-p nil
+                :event-timeout 0.02 :diagnostic-file nil :config-file "/tmp/lime-config.lisp")
+              '(:repl-port :start-repl-p :event-timeout :diagnostic-file))
+             '(:display-name ":5" :config-file "/tmp/lime-config.lisp"))))
+
+(test supervision-retains-paused-and-restarting-sessions
+  (let ((session (lime.dev::%make-development-session :running-p t :paused-p t)))
+    (is-true (lime.dev::%development-supervised-p session))
+    (setf (lime.dev::development-session-running-p session) nil
+          (lime.dev::development-session-restarting-p session) t)
+    (is-true (lime.dev::%development-supervised-p session))
+    (setf (lime.dev::development-session-restarting-p session) nil)
+    (is-false (lime.dev::%development-supervised-p session))
+    (is-false (lime.dev::%development-supervised-p nil))))
+
+(test paused-mailbox-can-inspect-and-fail-without-losing-the-session
+  (let* ((session (lime.dev::%make-development-session :backend :fake :running-p t :paused-p t))
+         (bad (lime.dev::make-development-request :function (lambda (backend)
+                                                              (declare (ignore backend)) (error "Nope")))))
+    (lime.dev::%enqueue-development-request session bad)
+    (lime.dev::%service-development-requests session :fake)
+    (is-true (lime.dev::development-request-completed-p bad))
+    (is (typep (lime.dev::development-request-failure bad) 'error))
+    (is-true (lime.dev::development-session-running-p session))
+    (is-true (lime.dev::development-session-paused-p session))))
+
+(test developer-mailbox-completes-work-on-its-owner-boundary
+  (let* ((session (lime.dev::%make-development-session :backend :fake :running-p t))
+         (request (lime.dev::make-development-request
+                   :function (lambda (backend) (list :backend backend)))))
+    (lime.dev::%enqueue-development-request session request)
+    (lime.dev::%service-development-requests session :fake)
+    (is-true (lime.dev::development-request-completed-p request))
+    (is (equal (lime.dev::development-request-values request)
+               '((:backend :fake))))
+    (is-false (lime.dev::development-request-failure request))))
+
+(defun run-tests ()
+  (run! 'lime-dev-suite))

test/gtk-cursor-probe.py

@@ -0,0 +1,30 @@
+"""Test-only GTK client: query live settings over stdin on an owned X server."""
+import sys
+import gi
+
+gi.require_version("Gtk", "3.0")
+from gi.repository import Gtk, GLib
+
+Gtk.init([])
+settings = Gtk.Settings.get_default()
+properties = ("gtk-cursor-theme-name", "gtk-cursor-theme-size", "gtk-theme-name",
+              "gtk-icon-theme-name", "gtk-font-name")
+
+
+def reply():
+    print("|".join(str(settings.get_property(name)) for name in properties), flush=True)
+    return False
+
+
+def request(source, condition):
+    if not sys.stdin.readline():
+        Gtk.main_quit()
+        return False
+    # Give queued X notifications a chance to dispatch before answering.
+    GLib.timeout_add(20, reply)
+    return True
+
+
+GLib.io_add_watch(sys.stdin, GLib.IO_IN | GLib.IO_HUP, request)
+reply()
+Gtk.main()

test/membership.lisp

@@ -0,0 +1,422 @@
+(in-package #:lime.test)
+(in-suite lime-suite)
+
+(test explicit-active-membership-move-is-one-transaction-and-keeps-both-desks
+  (dolist (mode '(:manual :master-stack :monocle))
+    (dolist (floating-p '(nil t))
+      (let* ((world (make-fixture))
+             (source (activate-view-strictly world "left" "code"))
+             (target (activate-view-strictly world "right" "play")))
+        (set-presentation-layout-mode world (presentation-id target) mode)
+        (when floating-p
+          (toggle-client-floating world (presentation-id source) "emacs"
+                                  :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2)))
+        (let ((revision (world-revision world))
+              (old-lease (lease-for-client world "game-client")))
+          (move-client-to-presentation world "emacs" (presentation-id target)
+                                       :tiled-insertion-position :front)
+          (is (= (1+ revision) (world-revision world)))
+          (is (eq source (current-presentation world "left")))
+          (is (eq target (current-presentation world "right")))
+          (is (equal "game" (client-activity-id (find-client world "emacs"))))
+          (is (equal "right" (lease-head-id world "emacs")))
+          (is (eq old-lease (lease-for-client world "game-client")))
+          (is (equal "terminal" (presentation-focus-client-id source)))
+          (is (equal "emacs" (presentation-focus-client-id target)))
+          (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "code")))))
+          (is (equal '("firefox") (mapcar #'placement-client-id (view-placements (find-view world "docs")))))
+          (is (equal '("game-client") (mapcar #'placement-client-id (view-placements (find-view world "play")))))
+          (is (presentation-dirty-p source))
+          (is (presentation-dirty-p target))
+          (is (eq mode (presentation-layout-mode target)))
+          (let ((placement (find "emacs" (presentation-placements target) :key #'placement-client-id :test #'equal)))
+            (is (eq (if floating-p :float :tile) (placement-kind placement)))
+            (when floating-p
+              (is (equal '(:x 1/4 :y 1/4 :width 1/2 :height 1/2) (placement-data placement)))))
+          (is (validate-world world)))))))
+
+(test explicit-live-move-failures-leave-membership-placements-and-lease-unchanged
+  (let* ((world (make-fixture))
+         (source (activate-view-strictly world "left" "code"))
+         (target (activate-view-strictly world "right" "play"))
+         (revision (world-revision world))
+         (lease (lease-for-client world "emacs"))
+         (source-placements (presentation-placements source))
+         (target-placements (presentation-placements target)))
+    ;; The old parked-move command still rejects an active destination.
+    (signals invalid-transition (move-client-to-activity world "emacs" "game" :target-head-id "right"))
+    (signals error (move-client-to-presentation world "emacs" (presentation-id target)
+                                               :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy"))))
+    (signals invalid-transition (move-client-to-presentation world "emacs" (presentation-id target)
+                                                            :tiled-insertion-position :invalid))
+    (signals unknown-entity (move-client-to-presentation world "emacs" "missing"))
+    (is (= revision (world-revision world)))
+    (is (eq lease (lease-for-client world "emacs")))
+    (is (eq source-placements (presentation-placements source)))
+    (is (eq target-placements (presentation-placements target)))
+    (is (equal "lime" (client-activity-id (find-client world "emacs"))))
+    (activate-view-strictly world "right" "browser")
+    (let ((revision (world-revision world)))
+      (signals invalid-transition (move-client-to-presentation world "emacs" (presentation-id target)))
+      (is (= revision (world-revision world))))
+    (is (validate-world world))))
+
+(test activity-deletion-cleans-checkpoints-cached-drafts-and-viewset-references
+  (let ((world (make-fixture)))
+    (create-activity world "old" "Old task")
+    (create-view world "old/view" "old" "Saved" nil)
+    (open-activity-draft world "left" "old")
+    (activate-view-strictly world "left" "old/view")
+    (activate-view-strictly world "left" "code")
+    (open-activity-draft world "right" "old")
+    (activate-view-strictly world "right" "browser")
+    (create-viewset world "mixed" "Mixed" (list (make-viewset-entry :head-id "left" :view-id "code")
+                                               (make-viewset-entry :head-id "right" :view-id "old/view")))
+    (create-viewset world "only-old" "Only old" (list (make-viewset-entry :head-id "right" :view-id "old/view")))
+    (let* ((revision (world-revision world))
+           (summary (activity-deletion-summary world "old"))
+           (drafts (getf summary :presentation-ids))
+           (left (current-presentation world "left"))
+           (right (current-presentation world "right")))
+      (is-true (getf summary :ready-p))
+      (is (= 2 (length drafts)))
+      (is (= 2 (getf summary :viewset-entry-count)))
+      (is (= revision (world-revision world)))
+      (delete-activity world "old" :expected-revision revision)
+      (signals unknown-entity (find-activity world "old"))
+      (signals unknown-entity (find-view world "old/view"))
+      (signals unknown-entity (find-viewset world "only-old"))
+      (dolist (id drafts) (signals unknown-entity (find-presentation world id)))
+      (is (equal '("code") (mapcar #'viewset-entry-view-id (viewset-entries (find-viewset world "mixed")))))
+      (is (eq left (current-presentation world "left")))
+      (is (eq right (current-presentation world "right")))
+      (is (= 3 (hash-table-count (lime.core::world-leases world))))
+      (is (= (1+ revision) (world-revision world)))
+      (is-true (validate-world world)))))
+
+(test activity-deletion-refuses-home-clients-even-hidden-or-shared-elsewhere
+  (let ((world (make-fixture)))
+    (create-activity world "music" "Music")
+    (create-client world "player" "music" :shared-p t)
+    (let ((revision (world-revision world)))
+      (signals invalid-transition (delete-activity world "music"))
+      (is (= revision (world-revision world))))
+    (let ((p (open-activity-draft world "left" "lime")))
+      (show-client-on-presentation world "player" (presentation-id p)))
+    (let ((revision (world-revision world)))
+      (signals invalid-transition (delete-activity world "music"))
+      (is (= revision (world-revision world)))
+      (is (equal "left" (lease-head-id world "player")))
+      (is-true (validate-world world)))))
+
+(test activity-deletion-refuses-even-empty-mounts-on-any-head
+  (let ((world (make-fixture)))
+    (create-activity world "empty" "Empty")
+    (open-activity-draft world "left" "empty")
+    (open-activity-draft world "right" "empty")
+    (let ((revision (world-revision world)))
+      (is (= 2 (length (getf (activity-deletion-summary world "empty") :head-ids))))
+      (signals invalid-transition (delete-activity world "empty"))
+      (is (= revision (world-revision world))))
+    (activate-view-strictly world "left" "code")
+    (signals invalid-transition (delete-activity world "empty"))
+    (activate-view-strictly world "right" "browser")
+    (delete-activity world "empty")
+    (is-true (validate-world world))))
+
+(test deleting-cached-shared-requests-never-retires-or-takes-the-client
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-activity world "borrower" "Borrower")
+    (create-view world "borrowed" "borrower" "Borrowed" (placements "terminal"))
+    (let ((p (open-activity-draft world "right" "borrower")))
+      (show-client-on-presentation world "terminal" (presentation-id p)))
+    (activate-view-strictly world "right" "browser")
+    (activate-view-strictly world "left" "code")
+    (let ((lease (lease-for-client world "terminal")))
+      (delete-activity world "borrower")
+      (is (eq lease (lease-for-client world "terminal")))
+      (is (equal "lime" (client-activity-id (find-client world "terminal"))))
+      (is-true (client-shared-p (find-client world "terminal")))
+      (is-true (validate-world world)))))
+
+(test stale-deletion-and-activation-plans-are-rejected
+  (let ((world (make-fixture)))
+    (create-activity world "old" "Old")
+    (let* ((summary (activity-deletion-summary world "old"))
+           (plan (build-strict-activation-plan (preflight-view-activation world "left" "code"))))
+      (create-client world "new" "old")
+      (let ((revision (world-revision world)))
+        (signals stale-transition-plan (delete-activity world "old" :expected-revision (getf summary :revision)))
+        (is (= revision (world-revision world))))
+      (retire-client world "new")
+      (delete-activity world "old")
+      (signals stale-transition-plan (commit-activation-plan world plan))
+      (is-true (validate-world world)))))
+
+(test shared-eligibility-does-not-duplicate-home-membership-or-grant-leases
+  (let* ((world (make-fixture)) (revision (world-revision world)))
+    (set-client-shared world "terminal" t)
+    (is (> (world-revision world) revision))
+    (is (equal "lime" (client-activity-id (find-client world "terminal"))))
+    (is-false (member "terminal" (activity-client-ids (find-activity world "game")) :test #'equal))
+    (is (member "terminal" (activity-available-client-ids world "game") :test #'equal))
+    (is-false (lease-for-client world "terminal"))
+    (signals invalid-activity-membership
+      (create-view world "bad" "game" "Bad" (placements "emacs")))
+    (create-view world "music" "game" "Music" (placements "terminal"))
+    (is-true (validate-world world))))
+
+(test shared-cross-activity-views-use-the-existing-strict-partial-take-policies
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-view world "music" "game" "Music" (placements "terminal" "game-client"))
+    (activate-view-strictly world "left" "code")
+    (let ((revision (world-revision world)))
+      (signals error (activate-view-strictly world "right" "music"))
+      (is (= revision (world-revision world))))
+    (activate-view-partially world "right" "music")
+    (is (equal "left" (lease-head-id world "terminal")))
+    (is (equal '("terminal") (presentation-unavailable-client-ids (current-presentation world "right"))))
+    (transfer-client-lease world "terminal" (presentation-id (current-presentation world "right")))
+    (is (equal "right" (lease-head-id world "terminal")))
+    (is (equal '("emacs") (presentation-client-ids (current-presentation world "left"))))
+    (is-true (validate-world world))
+    (activate-view-taking world "left" "code")
+    (is (equal "left" (lease-head-id world "terminal")))
+    (is-true (validate-world world))))
+
+(test shared-window-can-switch-activities-on-the-same-head-without-collision
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-view world "music" "game" "Music" (placements "terminal"))
+    (activate-view-strictly world "left" "code")
+    (activate-view-strictly world "left" "music")
+    (is (equal "left" (lease-head-id world "terminal")))
+    (is-true (validate-world world))))
+
+(test private-move-prunes-checkpoints-and-cached-drafts-without-switching-heads
+  (let ((world (make-fixture)))
+    (let ((cached (open-activity-draft world "left" "lime")))
+      (show-client-on-presentation world "emacs" (presentation-id cached))
+      (activate-view-strictly world "left" "code")
+      (activate-view-partially world "right" "docs")
+      (let* ((source (current-presentation world "left"))
+             (source-id (presentation-id source)))
+        (move-client-to-activity world "emacs" "game" :target-head-id "left")
+        (is (equal source-id (presentation-id (current-presentation world "left"))))
+        (is (equal "terminal" (presentation-focus-client-id source)))
+        (is (equal "game" (client-activity-id (find-client world "emacs"))))
+        (is-false (lease-for-client world "emacs"))
+        (is (eq cached source))
+        (is (equal '("terminal") (presentation-client-ids cached)))
+        (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "code")))))
+        (is (equal '("firefox") (mapcar #'placement-client-id (view-placements (find-view world "docs")))))
+        (is-false (presentation-unavailable-client-ids (current-presentation world "right")))
+        (let ((target (open-activity-draft world "left" "game")))
+          (is (equal '("emacs") (presentation-client-ids target)))
+          (is (equal "left" (lease-head-id world "emacs"))))
+        (is-true (validate-world world))))))
+
+(test move-retains-floating-geometry-and-destination-draft-settings
+  (let* ((world (make-fixture))
+         (target (open-activity-draft world "left" "game" :default-layout :monocle)))
+    (show-client-on-presentation world "game-client" (presentation-id target))
+    (activate-view-strictly world "left" "code")
+    (let ((source (current-presentation world "left")))
+      (toggle-client-floating world (presentation-id source) "terminal"
+                              :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))
+      (let ((data (copy-tree (placement-data (second (presentation-placements source))))))
+        (move-client-to-activity world "terminal" "game" :target-head-id "left")
+        (is (eq target (activity-draft-for-head world "game" "left")))
+        (is (eq :monocle (presentation-layout-mode target)))
+        (is (equal '("game-client" "terminal") (presentation-client-ids target)))
+        (is (eq :float (placement-kind (second (presentation-placements target)))))
+        (is (equal data (placement-data (second (presentation-placements target)))))))
+    (is-true (validate-world world))))
+
+(test membership-policy-failure-leaves-no-partial-transition
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let* ((revision (world-revision world))
+           (source (current-presentation world "left"))
+           (old-placements (presentation-placements source))
+           (count (hash-table-count (lime.core::world-presentations world))))
+      (signals error
+        (move-client-to-activity world "emacs" "game" :target-head-id "left"
+                                 :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy"))))
+      (is (= revision (world-revision world)))
+      (is (= count (hash-table-count (lime.core::world-presentations world))))
+      (is (eq old-placements (presentation-placements source)))
+      (is (equal "lime" (client-activity-id (find-client world "emacs"))))
+      (is (equal "left" (lease-head-id world "emacs")))
+      (signals error (move-client-to-activity world "emacs" "missing"))
+      (signals error (move-client-to-activity world "emacs" "game" :target-head-id "missing"))
+      (is (= revision (world-revision world)))
+      (is-true (validate-world world)))))
+
+(test revoke-sharing-prunes-foreign-requests-and-leases-but-keeps-home-checkpoints
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-view world "music" "game" "Music" (placements "terminal" "game-client") :focus-client-id "terminal")
+    (let ((cached (open-activity-draft world "left" "game")))
+      (show-client-on-presentation world "terminal" (presentation-id cached))
+      (activate-view-strictly world "left" "music")
+      (set-client-shared world "terminal" nil)
+      (is-false (lease-for-client world "terminal"))
+      (is (equal '("game-client") (presentation-client-ids cached)))
+      (is (equal "game-client" (presentation-focus-client-id (current-presentation world "left"))))
+      (is (equal '("game-client") (mapcar #'placement-client-id (view-placements (find-view world "music")))))
+      (is (equal '("emacs" "terminal") (mapcar #'placement-client-id (view-placements (find-view world "code")))))
+      (is-false (member "terminal" (activity-available-client-ids world "game") :test #'equal))
+      (is-true (validate-world world)))))
+
+(test moving-a-shared-client-changes-home-without-revoking-sharing
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (activate-view-strictly world "left" "code")
+    (move-client-to-activity world "terminal" "game" :target-head-id "left")
+    (is-true (client-shared-p (find-client world "terminal")))
+    (is (equal "game" (client-activity-id (find-client world "terminal"))))
+    (is (member "terminal" (mapcar #'placement-client-id (view-placements (find-view world "code"))) :test #'equal))
+    (is-false (lease-for-client world "terminal"))
+    (is (equal '("emacs") (presentation-client-ids (current-presentation world "left"))))
+    (is-true (validate-world world))
+    (retire-client world "terminal")
+    (is-true (validate-world world))
+    (is-false (presentation-client-ids (activity-draft-for-head world "game" "left")))))
+
+(test moving-without-a-target-draft-parks-even-with-the-same-home
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (move-client-to-activity world "emacs" "lime")
+    (is-false (lease-for-client world "emacs"))
+    (is (equal '("terminal") (presentation-client-ids (current-presentation world "left"))))
+    (is-true (validate-world world))))
+
+(test shared-viewset-still-rejects-two-simultaneous-claims
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-view world "music" "game" "Music" (placements "terminal"))
+    (create-viewset world "duplicate" "Duplicate"
+                    (list (make-viewset-entry :head-id "left" :view-id "code")
+                          (make-viewset-entry :head-id "right" :view-id "music")))
+    (let ((revision (world-revision world)))
+      (signals error (activate-viewset-taking world "duplicate"))
+      (is (= revision (world-revision world)))
+      (is-false (lease-for-client world "terminal")))))
+
+(test sharing-and-moving-invalidate-previous-activation-plans
+  (dolist (operation (list (lambda (w) (set-client-shared w "terminal" t))
+                          (lambda (w) (move-client-to-activity w "terminal" "game"))))
+    (let* ((world (make-fixture))
+           (plan (build-strict-activation-plan (preflight-view-activation world "left" "code"))))
+      (funcall operation world)
+      (signals stale-transition-plan (commit-activation-plan world plan))
+      (is-true (validate-world world)))))
+
+(test private-here-preserves-the-current-arrangement-and-lease
+  (dolist (mode '(:manual :master-stack :monocle))
+    (dolist (floating-p '(nil t))
+      (let ((world (make-fixture)))
+        (set-client-shared world "terminal" t)
+        (create-view world "music" "game" "Music" (placements "terminal" "game-client")
+                     :focus-client-id "terminal")
+        (let ((target (activate-view-strictly world "right" "music")))
+          (set-presentation-layout-mode world (presentation-id target) mode)
+          (when floating-p
+            (toggle-client-floating world (presentation-id target) "terminal"
+                                    :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2)))
+          ;; A foreign active arrangement can still request the leased client.
+          (let* ((source (activate-view-partially world "left" "code"))
+                 (revision (world-revision world))
+                 (lease (lease-for-client world "terminal"))
+                 (other-lease (lease-for-client world "emacs"))
+                 (before (lime.core::copy-presentation target))
+                 (checkpoint (view-placements (find-view world "music"))))
+            (is (equal '("terminal") (presentation-unavailable-client-ids source)))
+            (make-client-private-in-presentation world "terminal" (presentation-id target)
+                                                 :expected-revision revision)
+            (is (= (1+ revision) (world-revision world)))
+            (is (equalp before target))
+            (is (eq target (current-presentation world "right")))
+            (is (eq lease (lease-for-client world "terminal")))
+            (is (eq other-lease (lease-for-client world "emacs")))
+            (is (equal "game" (client-activity-id (find-client world "terminal"))))
+            (is-false (client-shared-p (find-client world "terminal")))
+            (is-false (member "terminal" (activity-client-ids (find-activity world "lime")) :test #'equal))
+            (is (= 1 (count "terminal" (activity-client-ids (find-activity world "game")) :test #'equal)))
+            (is (eq checkpoint (view-placements (find-view world "music"))))
+            (is (equal '("emacs") (mapcar #'placement-client-id (view-placements (find-view world "code")))))
+            (is (equal '("emacs") (presentation-client-ids source)))
+            (is-false (presentation-unavailable-client-ids source))
+            (is (validate-world world))
+            (make-client-private-in-presentation world "terminal" (presentation-id target))
+            (is (= (1+ revision) (world-revision world)))))))))
+
+(test private-here-at-original-home-keeps-local-checkpoints-and-cleans-cached-guests
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-view world "music" "game" "Music" (placements "terminal" "game-client")
+                 :focus-client-id "terminal")
+    (let ((cached (activate-view-strictly world "right" "music")))
+      (activate-view-strictly world "right" "browser")
+      (let* ((target (activate-view-strictly world "left" "code"))
+             (before (lime.core::copy-presentation target))
+             (checkpoint (view-placements (find-view world "code"))))
+        (make-client-private-in-presentation world "terminal" (presentation-id target))
+        (is (equalp before target))
+        (is (eq checkpoint (view-placements (find-view world "code"))))
+        (is (equal "lime" (client-activity-id (find-client world "terminal"))))
+        (is (equal '("game-client") (presentation-client-ids cached)))
+        (is (equal "game-client" (presentation-focus-client-id cached)))
+        (is (equal '("game-client") (mapcar #'placement-client-id (view-placements (find-view world "music")))))
+        (is (validate-world world))))))
+
+(test private-here-validates-before-committing-anything
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-view world "music" "game" "Music" (placements "terminal"))
+    (let* ((target (activate-view-strictly world "right" "music"))
+           (source (activate-view-partially world "left" "code"))
+           (revision (world-revision world))
+           (lease (lease-for-client world "terminal"))
+           (checkpoint (view-placements (find-view world "code")))
+           (old-source (lime.core::copy-presentation source))
+           (old-target (lime.core::copy-presentation target)))
+      (signals stale-transition-plan
+        (make-client-private-in-presentation world "terminal" (presentation-id target) :expected-revision -1))
+      (signals invalid-transition
+        (make-client-private-in-presentation world "terminal" (presentation-id source)))
+      (signals invalid-transition
+        (make-client-private-in-presentation world "firefox" (presentation-id source)))
+      (signals error
+        (make-client-private-in-presentation world "terminal" (presentation-id target)
+                                             :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy"))))
+      (is (= revision (world-revision world)))
+      (is (eq lease (lease-for-client world "terminal")))
+      (is (eq checkpoint (view-placements (find-view world "code"))))
+      (is (equalp old-source source))
+      (is (equalp old-target target))
+      (is (client-shared-p (find-client world "terminal")))
+      (is (equal "lime" (client-activity-id (find-client world "terminal"))))
+      (activate-view-strictly world "right" "browser")
+      (let ((revision (world-revision world)))
+        (signals invalid-transition
+          (make-client-private-in-presentation world "terminal" (presentation-id target)))
+        (is (= revision (world-revision world))))
+      (is (validate-world world)))))
+
+(test revocation-is-atomic-if-a-focus-policy-fails
+  (let ((world (make-fixture)))
+    (set-client-shared world "terminal" t)
+    (create-view world "music" "game" "Music" (placements "terminal"))
+    (activate-view-strictly world "right" "music")
+    (let ((revision (world-revision world)))
+      (signals error
+        (set-client-shared world "terminal" nil
+                           :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy"))))
+      (is (= revision (world-revision world)))
+      (is-true (client-shared-p (find-client world "terminal")))
+      (is (equal "right" (lease-head-id world "terminal")))
+      (is-true (validate-world world)))))

test/model.lisp

@@ -0,0 +1,955 @@
+(in-package #:lime.test)
+
+(def-suite lime-suite
+  :description "Lime's Activity/View/Head/Lease model.")
+
+(in-suite lime-suite)
+
+(defun placements (&rest client-ids)
+  (mapcar (lambda (client-id)
+            (make-placement :client-id client-id))
+          client-ids))
+
+(defun make-fixture ()
+  (let ((world (make-world)))
+    (create-head world "left")
+    (create-head world "right")
+    (create-activity world "lime" "Lime development")
+    (create-activity world "game" "Game")
+    (create-client world "emacs" "lime" :name "Emacs")
+    (create-client world "terminal" "lime" :name "Terminal")
+    (create-client world "firefox" "lime" :name "Firefox")
+    (create-client world "game-client" "game" :name "Game")
+    (create-view world "code" "lime" "Code"
+                 (placements "emacs" "terminal")
+                 :focus-client-id "emacs")
+    (create-view world "docs" "lime" "Docs"
+                 (placements "firefox" "emacs")
+                 :focus-client-id "firefox")
+    (create-view world "browser" "lime" "Browser"
+                 (placements "firefox")
+                 :focus-client-id "firefox")
+    (create-view world "play" "game" "Play"
+                 (placements "game-client"))
+    world))
+
+(defun lease-head-id (world client-id)
+  (let ((lease (lease-for-client world client-id)))
+    (and lease
+         (presentation-head-id
+          (find-presentation world (lease-presentation-id lease))))))
+
+(test views-respect-activity-ownership
+  (let ((world (make-fixture)))
+    (signals invalid-activity-membership
+      (create-view world "bad" "lime" "Bad"
+                   (placements "game-client")))))
+
+(test an-activity-needs-no-saved-view-to-own-live-head-local-drafts
+  (let ((world (make-world)))
+    (create-head world "left")
+    (create-head world "right")
+    (create-activity world "scratch" "Scratch")
+    (let ((left (open-activity-draft world "left" "scratch"))
+          (right (open-activity-draft world "right" "scratch")))
+      (is-false (presentation-source-view-id left))
+      (is-false (presentation-source-view-id right))
+      (is (eq left (activity-draft-for-head world "scratch" "left")))
+      (is (eq right (activity-draft-for-head world "scratch" "right")))
+      ;; Reopening an Activity resumes its one draft on that Head rather than
+      ;; inventing a blank checkpoint or a second draft.
+      (is (eq left (open-activity-draft world "left" "scratch")))
+      (is-false (activity-view-ids (find-activity world "scratch")))
+      (is-true (validate-world world)))))
+
+(test a-default-layout-only-initializes-new-drafts
+  (dolist (mode '(:manual :master-stack :monocle))
+    (let ((world (make-world)))
+      (create-head world "left")
+      (create-head world "right")
+      (create-activity world "work" "Work")
+      (let* ((revision (world-revision world))
+             (report (preflight-activity-draft world "left" "work" :default-layout mode)))
+        (is (eq mode (activation-report-desired-layout-mode report)))
+        (is (= revision (world-revision world)))
+        (is-false (activity-draft-for-head world "work" "left")))
+      (let ((draft (open-activity-draft world "left" "work" :default-layout mode)))
+        (is (eq mode (presentation-layout-mode draft)))
+        (when (eq mode :master-stack)
+          (is (equal '(:master-count 1 :master-ratio 3/5 :orientation :horizontal)
+                     (presentation-layout-options draft))))
+        (is-false (presentation-dirty-p draft))
+        (set-presentation-monocle-layout world (presentation-id draft))
+        (is (eq draft (open-activity-draft world "left" "work" :default-layout :master-stack)))
+        (is (eq :monocle (presentation-layout-mode draft)))
+        (is (eq :monocle
+                (activation-report-desired-layout-mode
+                 (preflight-activity-draft world "left" "work" :default-layout :manual))))
+        (is (eq mode (presentation-layout-mode
+                      (open-activity-draft world "right" "work" :default-layout mode))))
+        (is-true (validate-world world))
+        (let ((revision (world-revision world)))
+          (signals invalid-transition
+            (open-activity-draft world "left" "work" :default-layout :bogus))
+          (is (= revision (world-revision world))))))))
+
+(test hiding-is-a-head-local-draft-edit-and-showing-restores-the-activity-client
+  (let ((world (make-fixture)))
+    (let ((presentation (activate-view-strictly world "left" "code")))
+      ;; A saved View is a checkpoint, not the mutable list of every client
+      ;; owned by its Activity.  Firefox begins parked for this Code draft.
+      (is (equal (presentation-hidden-client-ids world presentation)
+                 '("firefox")))
+      (hide-focused-client-in-presentation world (presentation-id presentation))
+      ;; Hiding Emacs edits only this draft.  It releases the real lease and
+      ;; moves focus to Terminal, while the Activity and original Code View
+      ;; remain intact for later recall.
+      (is (equal (presentation-client-ids presentation) '("terminal")))
+      (is (equal (presentation-hidden-client-ids world presentation)
+                 '("emacs" "firefox")))
+      (is-false (lease-for-client world "emacs"))
+      (is (equal (presentation-focus-client-id presentation) "terminal"))
+      (is (equal (mapcar #'placement-client-id
+                         (view-placements (find-view world "code")))
+                 '("emacs" "terminal")))
+      (is-true (presentation-dirty-p presentation))
+      ;; Revealing puts the client back in the live draft and acquires a
+      ;; lease.  It never changes the older saved checkpoint implicitly.
+      (show-client-on-presentation world "emacs" (presentation-id presentation))
+      (focus-client-on-presentation world "emacs" (presentation-id presentation))
+      (is (equal (presentation-client-ids presentation) '("terminal" "emacs")))
+      (is (equal (presentation-hidden-client-ids world presentation)
+                 '("firefox")))
+      (is (equal (lease-head-id world "emacs") "left"))
+      (is-true (validate-world world)))))
+
+(test view-names-are-unique-within-an-activity-but-not-globally
+  (let ((world (make-world)))
+    (create-activity world "work" "Work")
+    (create-activity world "chill" "Chill")
+    (create-view world "work/code" "work" "Code" '())
+    (signals invalid-transition
+      (create-view world "work/code-2" "work" "code" '()))
+    (create-view world "chill/code" "chill" "Code" '())
+    (is-true (validate-world world))))
+
+(test distinct-views-of-one-activity-can-share-the-desktop
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let ((right (activate-view-strictly world "right" "browser")))
+      (is (equal (presentation-source-view-id right) "browser"))
+      (is (equal (lease-head-id world "emacs") "left"))
+      (is (equal (lease-head-id world "firefox") "right"))
+      (is-true (validate-world world)))))
+
+(test strict-preflight-is-read-only-and-reports-a-client-collision
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let ((report (preflight-view-activation world "right" "docs")))
+      (is-false (activation-report-ready-p report))
+      (is (find :client-leased
+                (activation-report-conflicts report)
+                :key #'activation-conflict-kind))
+      (signals activation-blocked
+        (build-strict-activation-plan report))
+      (is (equal (lease-head-id world "emacs") "left"))
+      (is-false (current-presentation world "right")))))
+
+(test partial-activation-preserves-the-incumbent-lease
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let ((right (activate-view-partially world "right" "docs")))
+      (is (equal (presentation-leased-client-ids world right)
+                 '("firefox")))
+      (is (member "emacs" (presentation-unavailable-client-ids right)
+                  :test #'equal))
+      (is (equal (lease-head-id world "emacs") "left"))
+      (is (equal (lease-head-id world "firefox") "right"))
+      (is-true (validate-world world)))))
+
+(test taking-a-client-relocates-only-the-live-placement
+  (let ((world (make-fixture)))
+    (let ((left (activate-view-strictly world "left" "code")))
+      (activate-view-taking world "right" "docs")
+      (is (equal (lease-head-id world "emacs") "right"))
+      (is-false (presentation-unavailable-client-ids left))
+      (is (equal (presentation-client-ids left) '("terminal")))
+      (is (equal (mapcar #'placement-client-id
+                         (view-placements (find-view world "code")))
+                 '("emacs" "terminal")))
+      (is-true (validate-world world)))))
+
+(test an-explicit-lease-transfer-is-a-general-command
+  (let ((world (make-fixture)))
+    (let ((left (activate-view-strictly world "left" "code"))
+          (right (activate-view-partially world "right" "docs")))
+      (transfer-client-lease world "emacs" (presentation-id right))
+      (is (equal (lease-head-id world "emacs") "right"))
+      (is-false (member "emacs" (presentation-client-ids left) :test #'equal))
+      (is-false (member "emacs" (presentation-unavailable-client-ids right)
+                        :test #'equal))
+      (is-true (validate-world world)))))
+
+(test reclaiming-is-explicit-after-a-lease-becomes-free
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let ((right (activate-view-partially world "right" "docs")))
+      ;; Switching the left Head away releases Emacs.  It does not
+      ;; spontaneously appear on the right until the user asks to reclaim it.
+      (activate-view-strictly world "left" "play")
+      (is-false (lease-for-client world "emacs"))
+      (is (equal (reclaim-available-slots world (presentation-id right))
+                 '("emacs")))
+      (is (equal (lease-head-id world "emacs") "right"))
+      (is-true (validate-world world)))))
+
+(test a-named-view-cannot-be-mounted-twice
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let ((report (preflight-view-activation world "right" "code")))
+      (is (find :view-mounted
+                (activation-report-conflicts report)
+                :key #'activation-conflict-kind))
+      (signals activation-blocked
+        (build-partial-activation-plan report)))))
+
+(test viewsets-swap-heads-as-one-atomic-activation
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (activate-view-strictly world "right" "play")
+    (create-viewset
+     world "after-work" "After work"
+     (list (make-viewset-entry :head-id "left" :view-id "play")
+           (make-viewset-entry :head-id "right" :view-id "code")))
+    ;; Each incoming View is currently mounted on the other target Head. A
+    ;; pair of ordinary one-Head commands would reject that intermediate state;
+    ;; a Viewset recognizes both old Presentations as one outgoing group.
+    (let* ((report (preflight-viewset-activation world "after-work"))
+           (result (commit-viewset-plan world (build-strict-viewset-plan report))))
+      (is-true (viewset-report-ready-p report))
+      (is (equal (presentation-source-view-id
+                  (current-presentation world "left"))
+                 "play"))
+      (is (equal (presentation-source-view-id
+                  (current-presentation world "right"))
+                 "code"))
+      (is (equal (lease-head-id world "game-client") "left"))
+      (is (equal (lease-head-id world "emacs") "right"))
+      (is (equal (mapcar #'car (viewset-result-presentation-ids result))
+                 '("left" "right")))
+      (is-true (validate-world world)))))
+
+(test viewsets-reuse-the-explicit-partial-and-take-lease-policies
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "browser")
+    (let ((right (activate-view-strictly world "right" "code")))
+      (create-viewset
+       world "docs-left" "Docs on left"
+       (list (make-viewset-entry :head-id "left" :view-id "docs")))
+      (let ((report (preflight-viewset-activation world "docs-left")))
+        (is-false (viewset-report-ready-p report))
+        (is (find :client-leased (viewset-report-conflicts report)
+                  :key #'viewset-conflict-kind))
+        (let ((result (commit-viewset-plan world
+                                           (build-partial-viewset-plan report))))
+          (declare (ignore result))
+          (is (equal (presentation-leased-client-ids
+                      world (current-presentation world "left"))
+                     '("firefox")))
+          (is (member "emacs"
+                      (presentation-unavailable-client-ids
+                       (current-presentation world "left"))
+                      :test #'equal))
+          (is (equal (lease-head-id world "emacs") "right"))))
+      ;; Recalling the same Viewset with :TAKE is a second deliberate command:
+      ;; it moves only the contested Emacs lease and degrades the incumbent.
+      (commit-viewset-plan
+       world (build-taking-viewset-plan
+              (preflight-viewset-activation world "docs-left")))
+      (is (equal (lease-head-id world "emacs") "left"))
+      (is-false (member "emacs" (presentation-client-ids right) :test #'equal))
+      (is-true (validate-world world)))))
+
+(test viewset-plans-reject-internal-window-duplication-and-staleness
+  (let ((world (make-fixture)))
+    (create-viewset
+     world "bad-combination" "Bad combination"
+     (list (make-viewset-entry :head-id "left" :view-id "code")
+           ;; Code and Docs both request Emacs. A Viewset cannot pick one
+           ;; merely because its entry happened to come first.
+           (make-viewset-entry :head-id "right" :view-id "docs")))
+    (let ((report (preflight-viewset-activation world "bad-combination")))
+      (is (find :client-requested (viewset-report-conflicts report)
+                :key #'viewset-conflict-kind))
+      (signals activation-blocked (build-partial-viewset-plan report))
+      (is-false (current-presentation world "left"))
+      (is-false (current-presentation world "right")))
+    (create-viewset world "valid" "Valid"
+                    (list (make-viewset-entry :head-id "left" :view-id "browser")))
+    (let ((plan (build-strict-viewset-plan
+                 (preflight-viewset-activation world "valid"))))
+      ;; Any intervening model transition invalidates a prepared whole-desk
+      ;; plan; a stale command cannot replace a newly changed Head.
+      (create-client world "later" "lime")
+      (signals stale-transition-plan (commit-viewset-plan world plan))
+      (is-false (current-presentation world "left"))
+      (is-true (validate-world world)))))
+
+(test new-windows-change-only-the-live-draft
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (create-client world "terminal-2" "lime" :name "Second terminal")
+      (show-client-on-presentation world "terminal-2" (presentation-id code))
+      (is (member "terminal-2" (presentation-client-ids code) :test #'equal))
+      (is-false (member "terminal-2"
+                        (mapcar #'placement-client-id
+                                (view-placements (find-view world "code")))
+                        :test #'equal))
+      ;; Recalling the historical checkpoint releases the new client's lease.
+      (activate-view-strictly world "left" "code")
+      (is-false (lease-for-client world "terminal-2"))
+      (is-true (validate-world world)))))
+
+(test focus-is-an-explicit-active-lease-command
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (focus-client-on-presentation world "terminal" (presentation-id code))
+      (is (equal (presentation-focus-client-id code) "terminal"))
+      (is-true (presentation-dirty-p code))
+      ;; Firefox belongs to the Activity but is not visible in this
+      ;; Presentation, so selecting it must not create an implicit lease.
+      (signals invalid-transition
+        (focus-client-on-presentation world "firefox" (presentation-id code)))
+      (is (equal (presentation-focus-client-id code) "terminal"))
+      (is-true (validate-world world)))))
+
+(test retiring-a-destroyed-client-removes-phantom-slots-everywhere
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (retire-client world "emacs")
+      (signals unknown-entity (find-client world "emacs"))
+      (is-false (member "emacs" (activity-client-ids (find-activity world "lime"))
+                        :test #'equal))
+      (is (equal (presentation-client-ids code) '("terminal")))
+      ;; This Presentation began with the fallback layout, so its tree remains
+      ;; implicit.  Resolving it must still have no ghost slot.
+      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
+                 '("terminal")))
+      (is (equal (mapcar #'placement-client-id
+                         (view-placements (find-view world "code")))
+                 '("terminal")))
+      (is-false (lease-for-client world "emacs"))
+      (is (equal (lease-head-id world "terminal") "left"))
+      (is-true (validate-world world)))))
+
+(test head-local-layouts-are-copied-and-explicitly-saved
+  (let ((world (make-fixture)))
+    (let ((saved-layout
+            (make-layout-split
+             :orientation :vertical
+             :ratio 2/3
+             :first (make-layout-leaf :client-id "emacs")
+             :second (make-layout-leaf :client-id "terminal"))))
+      (create-view world "layout" "lime" "Layout"
+                   (placements "emacs" "terminal")
+                   :layout-root saved-layout)
+      (let ((presentation (activate-view-strictly world "left" "layout")))
+        (is (equal (layout-node-client-ids
+                    (presentation-layout-root presentation))
+                   '("emacs" "terminal")))
+        (is-false (eq saved-layout (presentation-layout-root presentation)))
+        (set-presentation-layout-root
+         world
+         (presentation-id presentation)
+         (make-layout-split
+          :orientation :horizontal
+          :ratio 1/2
+          :first (make-layout-leaf :client-id "emacs")
+          :second (make-layout-leaf :client-id "terminal")))
+        (is (eq (layout-split-orientation
+                 (presentation-layout-root presentation))
+                :horizontal))
+        ;; The checkpoint remains vertical until the user explicitly updates it.
+        (is (eq (layout-split-orientation
+                 (view-layout-root (find-view world "layout")))
+                :vertical))
+        (update-view-from-presentation world "layout" (presentation-id presentation))
+        (is (eq (layout-split-orientation
+                 (view-layout-root (find-view world "layout")))
+                :horizontal))
+        (is-true (validate-world world))))))
+
+(test master-stack-is-a-head-local-saved-layout-policy
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (show-client-on-presentation world "firefox" (presentation-id code))
+      (set-presentation-master-stack-layout
+       world (presentation-id code) :master-count 1 :master-ratio 3/5)
+      (is (eq (presentation-layout-mode code) :master-stack))
+      (is (equal (presentation-layout-options code)
+                 '(:master-count 1 :master-ratio 3/5 :orientation :horizontal)))
+      (is (equal (layout-node-client-ids (presentation-layout-root code))
+                 '("emacs" "terminal" "firefox")))
+      (let ((layout (resolve-presentation-layout code 1000 600)))
+        (let ((master (cdr (assoc "emacs" layout :test #'equal)))
+              (first-stack (cdr (assoc "terminal" layout :test #'equal)))
+              (second-stack (cdr (assoc "firefox" layout :test #'equal))))
+          (is (= (geometry-width master) 600))
+          (is (= (geometry-width first-stack) 400))
+          (is (= (geometry-y first-stack) 0))
+          (is (= (geometry-y second-stack) 300))))
+      ;; The policy follows the live draft as clients arrive and persists only
+      ;; when explicitly checkpointed.
+      (create-client world "terminal-2" "lime")
+      (show-client-on-presentation world "terminal-2" (presentation-id code))
+      (is (equal (layout-node-client-ids (presentation-layout-root code))
+                 '("emacs" "terminal" "firefox" "terminal-2")))
+      (update-view-from-presentation world "code" (presentation-id code))
+      (is (eq (view-layout-mode (find-view world "code")) :master-stack))
+      (is-true (validate-world world)))))
+
+(test master-stack-weights-resize-each-column-independently-on-both-axes
+  (let* ((world (make-fixture))
+         (code (activate-view-strictly world "left" "code"))
+         (id (presentation-id code)))
+    (show-client-on-presentation world "firefox" id)
+    (dolist (client '("extra-1" "extra-2"))
+      (create-client world client "lime")
+      (show-client-on-presentation world client id))
+    (set-presentation-master-stack-layout world id :master-count 2 :master-ratio 3/5)
+    (set-client-tile-weight world id "terminal" 2)
+    (set-client-tile-weight world id "firefox" 2)
+    (flet ((geometry (client layout) (cdr (assoc client layout :test #'equal))))
+      (let ((layout (resolve-presentation-layout code 1000 600)))
+        ;; Master weights 1:2; stack weights 2:1:1. Neither changes column width.
+        (is (= 200 (geometry-height (geometry "emacs" layout))))
+        (is (= 400 (geometry-height (geometry "terminal" layout))))
+        (is (= 300 (geometry-height (geometry "firefox" layout))))
+        (is (= 150 (geometry-height (geometry "extra-1" layout))))
+        (is (= 150 (geometry-height (geometry "extra-2" layout))))
+        (is (= 600 (geometry-width (geometry "terminal" layout))))
+        (is (= 400 (geometry-width (geometry "firefox" layout)))))
+      (set-presentation-master-stack-layout world id :master-count 2
+                                           :master-ratio 1/2 :orientation :vertical)
+      (let ((layout (resolve-presentation-layout code 600 1000)))
+        (is (= 200 (geometry-width (geometry "emacs" layout))))
+        (is (= 400 (geometry-width (geometry "terminal" layout))))
+        (is (= 300 (geometry-width (geometry "firefox" layout))))
+        (is (= 150 (geometry-width (geometry "extra-1" layout))))
+        (is (= 150 (geometry-width (geometry "extra-2" layout))))
+        (is (= 500 (geometry-height (geometry "firefox" layout))))))
+    (is (equal "emacs" (presentation-focus-client-id code)))
+    (is-true (validate-world world))))
+
+(test tile-weights-follow-the-window-through-reordering-and-reflow
+  (let* ((world (make-fixture))
+         (code (activate-view-strictly world "left" "code"))
+         (id (presentation-id code)))
+    (show-client-on-presentation world "firefox" id)
+    (set-presentation-master-stack-layout world id :master-ratio 3/5)
+    (set-client-tile-weight world id "terminal" 2)
+    (focus-client-on-presentation world "terminal" id)
+    (swap-focused-layout-client world id)
+    (is (eq :master-stack (presentation-layout-mode code)))
+    (is (equal '("emacs" "firefox" "terminal") (presentation-client-ids code)))
+    (let ((tile (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal))))
+      (is (= 200 (geometry-y tile)))
+      (is (= 400 (geometry-height tile))))
+    (create-client world "extra" "lime")
+    (show-client-on-presentation world "extra" id)
+    (is (= 300 (geometry-height
+                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal)))))
+    (retire-client world "extra")
+    (is (= 400 (geometry-height
+                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal)))))
+    (hide-client-from-presentation world "firefox" id)
+    ;; A sole window fills its column, with its weight retained for future peers.
+    (is (= 600 (geometry-height
+                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal)))))
+    (show-client-on-presentation world "firefox" id)
+    (is (= 400 (geometry-height
+                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal)))))
+    (is-true (validate-world world))))
+
+(test tile-weights-survive-floating-resizing-and-layout-changes
+  (let* ((world (make-fixture))
+         (code (activate-view-strictly world "left" "code"))
+         (id (presentation-id code)))
+    (show-client-on-presentation world "firefox" id)
+    (set-presentation-master-stack-layout world id)
+    (set-client-tile-weight world id "terminal" 2)
+    (toggle-client-floating world id "terminal")
+    (set-client-floating-geometry world id "terminal" :width 1/2)
+    (update-view-from-presentation world "code" id)
+    ;; Float checkpoint copies must preserve the dormant tiling weight too.
+    (setf code (activate-view-strictly world "left" "code")
+          id (presentation-id code))
+    (toggle-client-floating world id "terminal")
+    (set-presentation-monocle-layout world id)
+    (set-presentation-manual-layout world id)
+    (set-presentation-master-stack-layout world id)
+    (is (= 400 (geometry-height
+                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal)))))
+    (is-true (validate-world world))))
+
+(test tile-weights-are-independent-view-checkpoints-and-head-local-edits
+  (let* ((world (make-fixture))
+         (code (activate-view-strictly world "left" "code"))
+         (id (presentation-id code))
+         (right (activate-view-strictly world "right" "browser")))
+    (set-presentation-master-stack-layout world id :master-count 2)
+    (set-client-tile-weight world id "terminal" 2)
+    (let ((saved (find "terminal" (view-placements (find-view world "code"))
+                       :key #'placement-client-id :test #'equal)))
+      (is (= 1 (placement-tile-weight saved))))
+    (update-view-from-presentation world "code" id)
+    (set-client-tile-weight world id "terminal" 1)
+    (is-true (presentation-dirty-p code))
+    (is (= 300 (geometry-height
+                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal)))))
+    (setf code (activate-view-strictly world "left" "code"))
+    (is (= 400 (geometry-height
+                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
+                            :test #'equal)))))
+    (is-false (presentation-dirty-p code))
+    (is (eq right (current-presentation world "right")))
+    (is-false (presentation-dirty-p right))
+    (is (equal "right" (lease-head-id world "firefox")))
+    (is-true (validate-world world))))
+
+(test invalid-tile-weight-edits-leave-the-draft-intact
+  (let* ((world (make-fixture))
+         (code (activate-view-strictly world "left" "code"))
+         (id (presentation-id code)))
+    (set-presentation-master-stack-layout world id)
+    (let ((revision (world-revision world))
+          (root (presentation-layout-root code)))
+      (dolist (weight '(0 -1 nope))
+        (signals invalid-transition (set-client-tile-weight world id "terminal" weight)))
+      (signals invalid-transition (set-client-tile-weight world id "firefox" 2))
+      (is (= revision (world-revision world)))
+      (is (eq root (presentation-layout-root code))))
+    (toggle-client-floating world id "terminal")
+    (let ((revision (world-revision world)))
+      (signals invalid-transition (set-client-tile-weight world id "terminal" 2))
+      (is (= revision (world-revision world))))
+    (set-presentation-monocle-layout world id)
+    (let ((revision (world-revision world)))
+      (signals invalid-transition (set-client-tile-weight world id "emacs" 2))
+      (is (= revision (world-revision world))))
+    (signals invalid-transition
+      (create-view world "bad-weight" "lime" "Bad weight"
+                   (list (make-placement :client-id "firefox" :data '(:tile-weight 0)))))
+    (signals invalid-transition
+      (master-stack-layout-root '("a" "b") :weights '(1)))
+    (signals invalid-transition
+      (master-stack-layout-root '("a" "b") :weights '(1 -1)))
+    (is-true (validate-world world))))
+
+(test master-stack-client-flow-honors-insertion-and-focus-policy
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (set-presentation-master-stack-layout world (presentation-id code)
+                                           :master-count 1 :master-ratio 3/5)
+      ;; :BACK is the familiar dwm-like behavior: the newcomer is focused but
+      ;; every existing master/stack slot stays put and it joins at the
+      ;; visual bottom of the stack.
+      (show-client-on-presentation world "firefox" (presentation-id code)
+                                   :tiled-insertion-position :back :focus-p t)
+      (is (equal (presentation-client-ids code)
+                 '("emacs" "terminal" "firefox")))
+      (is (equal (presentation-focus-client-id code) "firefox"))
+      (let ((layout (resolve-presentation-layout code 1000 600)))
+        (is (= (geometry-y (cdr (assoc "firefox" layout :test #'equal))) 300)))
+      ;; Placement order points from master toward the bottom of the stack,
+      ;; so closing the focused lowest client with :PREVIOUS focuses Terminal.
+      (retire-client world "firefox" :focus-direction :previous)
+      (is (equal (presentation-focus-client-id code) "terminal"))
+      ;; The same engine also admits a different user policy without changing
+      ;; the master/stack implementation itself: :FRONT creates a new master.
+      (create-client world "browser-2" "lime")
+      (show-client-on-presentation world "browser-2" (presentation-id code)
+                                   :tiled-insertion-position :front :focus-p t)
+      (is (equal (presentation-client-ids code)
+                 '("browser-2" "emacs" "terminal")))
+      (is (equal (presentation-focus-client-id code) "browser-2"))
+      (retire-client world "browser-2" :focus-direction :previous)
+      ;; There is nothing before master, so the opposite direction is the
+      ;; graceful edge fallback.
+      (is (equal (presentation-focus-client-id code) "emacs"))
+      (is-true (validate-world world)))))
+
+(test monocle-client-flow-makes-new-clients-the-current-cycle-entry
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (set-presentation-monocle-layout world (presentation-id code))
+      ;; In monocle placement order is the cycle below the visible client. A
+      ;; newcomer therefore goes first and becomes the one full-screen tile.
+      (show-client-on-presentation world "firefox" (presentation-id code)
+                                   :tiled-insertion-position :front :focus-p t)
+      (is (equal (presentation-client-ids code)
+                 '("firefox" "emacs" "terminal")))
+      (is (equal (presentation-focus-client-id code) "firefox"))
+      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
+                 '("firefox")))
+      ;; The next client in that order is the natural close target.  Exercise
+      ;; RETIRE-CLIENT's per-container policy hook, used by the X11 adapter.
+      (retire-client world "firefox"
+                     :focus-direction (lambda (container)
+                                        (declare (ignore container))
+                                        :next))
+      (is (equal (presentation-focus-client-id code) "emacs"))
+      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
+                 '("emacs")))
+      (is-true (validate-world world)))))
+
+(test monocle-renders-only-the-focused-tiled-client
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (set-presentation-monocle-layout world (presentation-id code))
+      (is (eq (presentation-layout-mode code) :monocle))
+      (let ((layout (resolve-presentation-layout code 800 600)))
+        (is (equal (mapcar #'car layout) '("emacs")))
+        (is (= (geometry-width (cdar layout)) 800)))
+      (focus-client-on-presentation world "terminal" (presentation-id code))
+      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
+                 '("terminal")))
+      (is-true (validate-world world)))))
+
+(test floating-placements-have-normalized-geometry-and-rejoin-tiling
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (toggle-focused-client-floating world (presentation-id code))
+      (let ((placement (find "emacs" (presentation-placements code)
+                             :key #'placement-client-id :test #'equal)))
+        (is (eq (placement-kind placement) :float))
+        (is (equal (placement-data placement)
+                   '(:x 1/8 :y 1/8 :width 3/4 :height 3/4))))
+      ;; The float is independent of the tiled fallback tree and is resolved
+      ;; after tiled content so a renderer may keep it above the tiles.
+      (let ((layout (resolve-presentation-layout code 800 600)))
+        (is (equal (mapcar #'car layout) '("terminal" "emacs")))
+        (let ((float (cdr (assoc "emacs" layout :test #'equal)))
+              (tile (cdr (assoc "terminal" layout :test #'equal))))
+          (is (= (geometry-x float) 100))
+          (is (= (geometry-y float) 75))
+          (is (= (geometry-width float) 600))
+          (is (= (geometry-height float) 450))
+          (is (= (geometry-width tile) 800))))
+      (set-client-floating-geometry world (presentation-id code) "emacs"
+                                    :x 1/4 :y 1/5 :width 1/2 :height 2/5)
+      (let ((float (cdr (assoc "emacs"
+                               (resolve-presentation-layout code 800 600)
+                               :test #'equal))))
+        (is (= (geometry-x float) 200))
+        (is (= (geometry-y float) 120))
+        (is (= (geometry-width float) 400))
+        (is (= (geometry-height float) 240)))
+      (toggle-client-floating world (presentation-id code) "emacs")
+      (let ((placement (find "emacs" (presentation-placements code)
+                             :key #'placement-client-id :test #'equal)))
+        (is (eq (placement-kind placement) :tile))
+        (is-false (placement-data placement)))
+      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
+                 '("emacs" "terminal")))
+      (is-true (validate-world world)))))
+
+(test floating-geometry-is-an-explicitly-saved-head-local-checkpoint-change
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (toggle-client-floating world (presentation-id code) "terminal"
+                              :data '(:x 1/5 :y 1/6 :width 1/2 :height 1/2))
+      ;; The named checkpoint remains tiled until the user asks to update it.
+      (is (eq (placement-kind
+               (find "terminal" (view-placements (find-view world "code"))
+                     :key #'placement-client-id :test #'equal))
+              :tile))
+      (update-view-from-presentation world "code" (presentation-id code))
+      (let ((saved (find "terminal" (view-placements (find-view world "code"))
+                         :key #'placement-client-id :test #'equal)))
+        (is (eq (placement-kind saved) :float))
+        (is (equal (placement-data saved)
+                   '(:x 1/5 :y 1/6 :width 1/2 :height 1/2))))
+      (set-client-floating-geometry world (presentation-id code) "terminal"
+                                    :x 1/4)
+      (is (equal (placement-data
+                  (find "terminal" (view-placements (find-view world "code"))
+                        :key #'placement-client-id :test #'equal))
+                 '(:x 1/5 :y 1/6 :width 1/2 :height 1/2)))
+      (is-true (validate-world world)))))
+
+(test master-stack-reflows-when-a-client-enters-or-leaves-floating
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (show-client-on-presentation world "firefox" (presentation-id code))
+      (set-presentation-master-stack-layout world (presentation-id code)
+                                           :master-count 1 :master-ratio 3/5)
+      (toggle-client-floating world (presentation-id code) "terminal")
+      (is (eq (presentation-layout-mode code) :master-stack))
+      (is (equal (layout-node-client-ids (presentation-layout-root code))
+                 '("emacs" "firefox")))
+      (let ((layout (resolve-presentation-layout code 1000 600)))
+        (is (= (geometry-width (cdr (assoc "emacs" layout :test #'equal))) 600))
+        (is (= (geometry-width (cdr (assoc "firefox" layout :test #'equal))) 400))
+        (is (= (geometry-width (cdr (assoc "terminal" layout :test #'equal)))
+               750)))
+      (toggle-client-floating world (presentation-id code) "terminal")
+      (is (equal (layout-node-client-ids (presentation-layout-root code))
+                 '("emacs" "terminal" "firefox")))
+      (is-true (validate-world world)))))
+
+(test manual-layout-commands-edit-the-focused-nearest-split
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (adjust-focused-layout-split-ratio world (presentation-id code) 1/10)
+      (is (eq (presentation-layout-mode code) :manual))
+      (is (= (layout-split-ratio (presentation-layout-root code)) 3/5))
+      (set-focused-layout-split-orientation world (presentation-id code)
+                                            :vertical)
+      (is (eq (layout-split-orientation (presentation-layout-root code))
+              :vertical))
+      (swap-focused-layout-client world (presentation-id code))
+      (is (equal (layout-node-client-ids (presentation-layout-root code))
+                 '("terminal" "emacs")))
+      (is-true (validate-world world)))))
+
+(test promoting-a-client-creates-a-master-stack-draft
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (show-client-on-presentation world "firefox" (presentation-id code))
+      (focus-client-on-presentation world "terminal" (presentation-id code))
+      (promote-client-to-master world (presentation-id code) "terminal")
+      (is (eq (presentation-layout-mode code) :master-stack))
+      (is (equal (layout-node-client-ids (presentation-layout-root code))
+                 '("terminal" "emacs" "firefox")))
+      (is (equal (mapcar #'placement-client-id
+                         (presentation-placements code))
+                 '("terminal" "emacs" "firefox")))
+      (is-true (validate-world world)))))
+
+(test resuming-a-cached-presentation-preserves-its-draft
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (create-client world "terminal-2" "lime")
+      (show-client-on-presentation world "terminal-2" (presentation-id code))
+      (activate-view-strictly world "left" "play")
+      (let ((resumed (resume-presentation-strictly world "left"
+                                                    (presentation-id code))))
+        (is (eq code resumed))
+        (is (member "terminal-2" (presentation-client-ids resumed)
+                    :test #'equal))
+        (is (equal (lease-head-id world "terminal-2") "left"))
+        (is-true (presentation-dirty-p resumed))
+        (is-true (validate-world world))))))
+
+(test resume-keeps-current-locations-instead-of-recalling-checkpoint-requests
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (activate-view-strictly world "left" "play")
+      (activate-view-strictly world "right" "docs")
+      (let ((report (preflight-presentation-resume world "left"
+                                                    (presentation-id code))))
+        (is (activation-report-ready-p report))
+        (is (equal '("terminal") (mapcar #'placement-client-id (activation-report-desired-placements report)))))
+      (let ((resumed (resume-presentation-strictly world "left"
+                                                     (presentation-id code))))
+        (is (eq code resumed))
+        (is-false (presentation-unavailable-client-ids resumed))
+        (is (equal (lease-head-id world "terminal") "left"))
+        (is (equal (lease-head-id world "emacs") "right"))
+        (is-true (validate-world world))))))
+
+(test updating-a-view-is-explicit
+  (let ((world (make-fixture)))
+    (let ((code (activate-view-strictly world "left" "code")))
+      (create-client world "terminal-2" "lime")
+      (show-client-on-presentation world "terminal-2" (presentation-id code))
+      (update-view-from-presentation world "code" (presentation-id code))
+      (is (member "terminal-2"
+                  (mapcar #'placement-client-id
+                          (view-placements (find-view world "code")))
+                  :test #'equal))
+      (is-false (presentation-dirty-p code)))))
+
+(test a-degraded-presentation-cannot-silently-overwrite-a-view
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let ((right (activate-view-partially world "right" "docs")))
+      (signals degraded-presentation-update
+        (update-view-from-presentation world "docs" (presentation-id right))))))
+
+(test topology-reconciliation-moves-a-removed-heads-live-draft-intact
+  (let ((world (make-fixture)))
+    (let* ((code (activate-view-strictly world "left" "code"))
+           (browser (activate-view-strictly world "right" "browser"))
+           (report (preflight-head-topology-reconciliation world
+                                                             '("left" "dock"))))
+      (is (equal (head-topology-report-added-head-ids report) '("dock")))
+      (is (equal (head-topology-report-removed-head-ids report) '("right")))
+      (is (equal (mapcar #'head-topology-source-presentation-id
+                         (head-topology-report-removed-active-sources report))
+                 (list (presentation-id browser))))
+      (let ((result
+              (commit-head-topology-reconciliation-plan
+               world
+               (build-head-topology-reconciliation-plan
+                report
+                :moves (list (make-head-topology-move
+                              :from-head-id "right" :to-head-id "dock"))))))
+        (is (equal (head-topology-result-moved-presentation-ids result)
+                   (list (presentation-id browser))))
+        (is (eq (current-presentation world "left") code))
+        (is (eq (current-presentation world "dock") browser))
+        (is (equal (presentation-head-id browser) "dock"))
+        (is (equal (lease-head-id world "firefox") "dock"))
+        (signals unknown-entity (find-head world "right"))
+        (is-true (validate-world world))))))
+
+(test topology-reconciliation-suspends-an-unmoved-draft-and-allows-rehoming
+  (let ((world (make-fixture)))
+    (activate-view-strictly world "left" "code")
+    (let* ((browser (activate-view-strictly world "right" "browser"))
+           (remove-report (preflight-head-topology-reconciliation world '("left")))
+           (result
+             (commit-head-topology-reconciliation-plan
+              world (build-head-topology-reconciliation-plan remove-report))))
+      (is (equal (head-topology-result-suspended-presentation-ids result)
+                 (list (presentation-id browser))))
+      (is-false (presentation-head-id browser))
+      (is-false (lease-for-client world "firefox"))
+      (let ((add-report
+              (preflight-head-topology-reconciliation world '("left" "laptop"))))
+        (commit-head-topology-reconciliation-plan
+         world (build-head-topology-reconciliation-plan add-report)))
+      (let ((resumed (resume-presentation-strictly world "laptop"
+                                                    (presentation-id browser))))
+        (is (eq resumed browser))
+        (is (equal (presentation-head-id browser) "laptop"))
+        (is (equal (lease-head-id world "firefox") "laptop"))
+        (is-true (validate-world world))))))
+
+(test topology-reconciliation-rejects-ambiguous-destinations-without-mutation
+  (let ((world (make-fixture)))
+    (create-head world "third")
+    (activate-view-strictly world "left" "code")
+    (activate-view-strictly world "right" "browser")
+    (activate-view-strictly world "third" "play")
+    (let ((report (preflight-head-topology-reconciliation world '("left"))))
+      (signals invalid-transition
+        (build-head-topology-reconciliation-plan
+         report
+         :moves (list (make-head-topology-move :from-head-id "right"
+                                                :to-head-id "left")
+                      (make-head-topology-move :from-head-id "third"
+                                                :to-head-id "left"))))
+      (is (current-presentation world "right"))
+      (is (current-presentation world "third"))
+      (is-true (validate-world world)))))
+
+(test stale-plans-cannot-overwrite-newer-state
+  (let ((world (make-fixture)))
+    (let* ((report (preflight-view-activation world "left" "code"))
+           (plan (build-strict-activation-plan report)))
+      (create-client world "terminal-2" "lime")
+      (signals stale-transition-plan
+        (commit-activation-plan world plan))
+      (is-false (current-presentation world "left")))))
+
+(test activity-is-one-live-arrangement-across-independently-selected-heads
+  (let* ((world (make-fixture))
+         (left (open-activity-draft world "left" "lime" :default-layout :master-stack))
+         (right (open-activity-draft world "right" "lime" :default-layout :monocle)))
+    (show-client-on-presentation world "emacs" (presentation-id left))
+    (show-client-on-presentation world "firefox" (presentation-id right))
+    (set-presentation-layout-mode world (presentation-id left) :master-stack :layout-options '(:master-ratio 2/3))
+    (dotimes (i 3)
+      (open-activity-draft world "right" "game")
+      (is (equal "left" (lease-head-id world "emacs")))
+      (is-false (lease-for-client world "firefox"))
+      (open-activity-draft world "left" "game")
+      (is-false (lease-for-client world "emacs"))
+      ;; Return in either order, independently. No save/recall or policy choice.
+      (dolist (head (if (evenp i) '("right" "left") '("left" "right")))
+        (is (activation-report-ready-p (preflight-activity-draft world head "lime")))
+        (open-activity-draft world head "lime"))
+      (is (eq left (current-presentation world "left")))
+      (is (eq right (current-presentation world "right")))
+      (is (equal "left" (lease-head-id world "emacs")))
+      (is (equal "right" (lease-head-id world "firefox"))))
+    (is (= 2/3 (getf (presentation-layout-options left) :master-ratio)))
+    (is (eq :monocle (presentation-layout-mode right)))
+    ;; Explicit relocation changes the source even after another round trip.
+    (show-client-on-presentation world "firefox" (presentation-id left))
+    (transfer-client-lease world "firefox" (presentation-id left))
+    (is-false (presentation-client-ids right))
+    (open-activity-draft world "right" "game")
+    (open-activity-draft world "right" "lime")
+    (is-false (presentation-client-ids right))
+    (is (equal "left" (lease-head-id world "firefox")))
+    ;; Hiding does not resurface through another arrangement or a return.
+    (hide-client-from-presentation world "firefox" (presentation-id left))
+    (open-activity-draft world "left" "game")
+    (open-activity-draft world "left" "lime")
+    (is-false (lease-for-client world "firefox"))
+    (is (equal '("emacs") (presentation-client-ids left)))
+    (is-true (validate-world world))))
+
+(test first-visit-to-inactive-activity-does-not-gather-other-heads-windows
+  (let* ((world (make-fixture)) (left (open-activity-draft world "left" "lime")))
+    (show-client-on-presentation world "emacs" (presentation-id left))
+    (open-activity-draft world "left" "game")
+    (is-false (presentation-client-ids (open-activity-draft world "right" "lime")))
+    (is-false (lease-for-client world "emacs"))
+    ;; Summoning a not-currently-visible client also updates its old location.
+    (show-client-on-presentation world "emacs" (presentation-id (current-presentation world "right")))
+    (is-false (presentation-client-ids left))
+    (open-activity-draft world "left" "lime")
+    (is (equal "right" (lease-head-id world "emacs")))
+    (is-true (validate-world world))))
+
+(test checkpoints-edit-one-working-arrangement-without-creating-hidden-workspaces
+  (let* ((world (make-fixture)) (left (open-activity-draft world "left" "lime")))
+    (activate-view-strictly world "left" "code")
+    (is (eq left (current-presentation world "left")))
+    (hide-client-from-presentation world "emacs" (presentation-id left))
+    (open-activity-draft world "left" "game")
+    (is (eq left (open-activity-draft world "left" "lime")))
+    (is (equal '("terminal") (presentation-client-ids left)))
+    (activate-view-strictly world "left" "code")
+    (is (equal '("emacs" "terminal") (presentation-client-ids left)))
+    (is-false (presentation-dirty-p left))
+    ;; Recalling the checkpoint elsewhere while the old side is inactive
+    ;; changes live locations and detaches its old source label, not the View.
+    (open-activity-draft world "left" "game")
+    (activate-view-strictly world "right" "code")
+    (is-false (presentation-source-view-id left))
+    (is-false (presentation-client-ids left))
+    (open-activity-draft world "left" "lime")
+    (is (equal "right" (lease-head-id world "emacs")))
+    (is (= 2 (length (view-placements (find-view world "code")))))
+    (is-true (validate-world world))))
+
+(test partially-recalled-view-does-not-retry-missing-windows-on-activity-return
+  (let* ((world (make-fixture))
+         (left (activate-view-strictly world "left" "code"))
+         (right (activate-view-partially world "right" "docs")))
+    (is (equal '("emacs") (presentation-unavailable-client-ids right)))
+    (open-activity-draft world "right" "game")
+    (open-activity-draft world "left" "game")
+    (open-activity-draft world "right" "lime")
+    (is-false (lease-for-client world "emacs"))
+    (is (equal '("firefox") (presentation-client-ids right)))
+    (open-activity-draft world "left" "lime")
+    (is (eq left (current-presentation world "left")))
+    (is (equal "left" (lease-head-id world "emacs")))
+    (is-true (validate-world world))))
+
+(defun run-tests ()
+  (run! 'lime-suite))

test/package.lisp

@@ -0,0 +1,3 @@
+(defpackage #:lime.test
+  (:use #:cl #:fiveam #:lime.core)
+  (:export #:run-tests))

test/persistence.lisp

@@ -0,0 +1,215 @@
+(defpackage #:lime.persistence.test
+  (:use #:cl #:fiveam #:lime.core #:lime.persistence)
+  (:export #:run-tests))
+(in-package #:lime.persistence.test)
+(def-suite persistence-suite)
+(in-suite persistence-suite)
+
+(defun fixture ()
+  (let ((world (make-world)))
+    (dolist (head '("left" "right")) (create-head world head))
+    (create-activity world "work" "Lime 日本語")
+    (create-activity world "game" "Game")
+    (dolist (id '("editor" "terminal" "browser" "hidden"))
+      (create-client world id "work" :name id :metadata '(:note "plain data")))
+    (create-view world "code" "work" "Code"
+                 (mapcar (lambda (id) (make-placement :client-id id)) '("editor" "terminal"))
+                 :layout-mode :master-stack :layout-options '(:master-ratio 2/3)
+                 :focus-client-id "terminal")
+    (create-view world "docs" "work" "Docs"
+                 (mapcar (lambda (id) (make-placement :client-id id)) '("browser" "editor"))
+                 :layout-mode :monocle :focus-client-id "browser")
+    (activate-view-strictly world "left" "code")
+    (activate-view-partially world "right" "docs")
+    (let ((p (current-presentation world "left")))
+      (set-client-tile-weight world (presentation-id p) "editor" 3/2)
+      (toggle-client-floating world (presentation-id p) "terminal"
+                              :data '(:x 1/4 :y 1/3 :width 1/2 :height 1/2)))
+    ;; Make a cached draft as well as the active checkpoint realizations.
+    (open-activity-draft world "left" "game")
+    (activate-view-strictly world "left" "code")
+    (create-viewset world "desk" "Desk" (list (make-viewset-entry :head-id "left" :view-id "code")
+                                             (make-viewset-entry :head-id "right" :view-id "docs")))
+    world))
+
+(test deleted-activity-and-associated-library-stay-deleted-after-restore
+  (let ((world (fixture)))
+    (create-view world "game/empty" "game" "Empty" nil)
+    (create-viewset world "obsolete" "Obsolete" (list (make-viewset-entry :head-id "left" :view-id "game/empty")))
+    (delete-activity world "game")
+    (let ((restored (restore-world (snapshot-world world))))
+      (is (equalp (snapshot-world world) (snapshot-world restored)))
+      (signals unknown-entity (find-activity restored "game"))
+      (signals unknown-entity (find-view restored "game/empty"))
+      (signals unknown-entity (find-viewset restored "obsolete"))
+      (is-true (validate-world restored)))))
+
+(test sharing-and-moved-drafts-survive-roundtrip
+  (let ((world (fixture)))
+    (set-client-shared world "terminal" t)
+    (open-activity-draft world "left" "game")
+    (show-client-on-presentation world "terminal" (presentation-id (current-presentation world "left")))
+    (move-client-to-activity world "browser" "game" :target-head-id "right")
+    (let ((restored (restore-world (snapshot-world world))))
+      (is (equalp (snapshot-world world) (snapshot-world restored)))
+      (is-true (client-shared-p (find-client restored "terminal")))
+      (is (equal "work" (client-activity-id (find-client restored "terminal"))))
+      (is (equal "game" (presentation-activity-id
+                           (find-presentation restored (lease-presentation-id (lease-for-client restored "terminal"))))))
+      (is (equal '("browser") (presentation-client-ids (activity-draft-for-head restored "game" "right")))))
+    (let ((data (snapshot-world world)))
+      (setf (getf (first (getf data :clients)) :shared) :invalid)
+      (signals error (restore-world data)))))
+
+(test version-one-snapshots-upgrade-to-private-clients
+  (let* ((world (fixture)) (data (snapshot-world world)))
+    (setf (getf data :version) 1)
+    (dolist (row (getf data :clients)) (remf row :shared))
+    (let ((restored (restore-world data)))
+      (is (equalp (snapshot-world world) (snapshot-world restored)))
+      (is-false (client-shared-p (find-client restored "terminal"))))))
+
+(test lossless-model-roundtrip-and-independent-objects
+  (let* ((world (fixture)) (data (snapshot-world world)) (restored (restore-world data)))
+    (is (equalp data (snapshot-world restored)))
+    (is-true (validate-world restored))
+    (is (equal '("hidden")
+               (set-difference (activity-client-ids (find-activity restored "work"))
+                               '("editor" "terminal" "browser") :test #'equal)))
+    (is-false (presentation-unavailable-client-ids (current-presentation restored "right")))
+    (is (= 3 (hash-table-count (lime.core::world-leases restored))))
+    (setf (client-metadata (find-client restored "editor")) '(:changed t))
+    (is (equal '(:note "plain data") (client-metadata (find-client world "editor"))))
+    (let ((old (hash-table-count (lime.core::world-presentations restored))))
+      (open-activity-draft restored "right" "game")
+      (is (= (1+ old) (hash-table-count (lime.core::world-presentations restored)))))))
+
+(test checkpoints-and-dirty-drafts-are-distinct
+  (let* ((world (fixture)) (p (current-presentation world "left")))
+    (hide-client-from-presentation world "terminal" (presentation-id p))
+    (let* ((restored (restore-world (snapshot-world world))) (p2 (current-presentation restored "left")))
+      (is-true (presentation-dirty-p p2))
+      (is (equal '("editor") (presentation-client-ids p2)))
+      (is (= 2 (length (view-placements (find-view restored "code")))))
+      (is (member "terminal" (presentation-hidden-client-ids restored p2) :test #'equal)))))
+
+(test manual-tree-and-empty-library-roundtrip
+  (let* ((world (fixture)) (p (current-presentation world "left")))
+    (set-presentation-manual-layout world (presentation-id p))
+    (set-presentation-layout-root world (presentation-id p)
+      (make-layout-split :orientation :vertical :ratio 2/5
+                        :first (make-layout-leaf :client-id "editor")
+                        :second (make-layout-leaf :client-id "terminal")))
+    (is (equalp (snapshot-world world) (snapshot-world (restore-world (snapshot-world world))))))
+  (let ((world (make-world)))
+    (create-head world "one") (create-activity world "plain" "Plain")
+    (open-activity-draft world "one" "plain")
+    (let ((restored (restore-world (snapshot-world world))))
+      (is-false (activity-view-ids (find-activity restored "plain")))
+      (is-false (presentation-source-view-id (current-presentation restored "one")))
+      (is-true (validate-world restored)))))
+
+(test displays-have-independent-default-stores
+  (is (not (equal (default-session-path ":0") (default-session-path ":99"))))
+  (is (not (equal (default-session-path ":0") (default-session-path "_3A0")))))
+
+(test malformed-snapshots-are-rejected-before-a-world-is-returned
+  (let ((data (snapshot-world (fixture))))
+    (flet ((reject (function)
+             (let ((copy (copy-tree data))) (funcall function copy) (signals error (restore-world copy)))))
+      (reject (lambda (x) (setf (getf x :version) 99)))
+      (reject (lambda (x) (setf (getf (first (getf x :activities)) :clients) '("bogus"))))
+      (reject (lambda (x) (setf (getf (first (getf x :clients)) :activity) "missing")))
+      (reject (lambda (x) (setf (getf (first (getf x :heads)) :active) "missing")))
+      (reject (lambda (x) (setf (getf (first (getf x :presentations)) :layout) :bogus)))
+      (reject (lambda (x) (setf (getf (first (getf x :presentations)) :dirty) 12)))
+      (reject (lambda (x)
+                ;; Give a second live arrangement an actual duplicate client.
+                (let ((right (find "right" (getf x :presentations) :key (lambda (p) (getf p :head)) :test #'equal)))
+                  (push '(:client "editor" :kind :float :data (:x 0 :y 0 :width 1 :height 1))
+                        (getf right :placements)))))
+      (reject (lambda (x) (push (first (getf x :views)) (getf x :views)))))))
+
+(test plain-data-only
+  (is-true (check-data (make-list 10000 :initial-element :wide)))
+  (signals error (check-data (list :callback #'identity)))
+  (signals error (check-data (make-world)))
+  (let ((cycle (list :cycle)))
+    (setf (cdr cycle) cycle)
+    (signals error (check-data cycle)))
+  (signals error (check-data (loop repeat 140 for x = '(:end) then (list x) finally (return x)))))
+
+(test legacy-arrangements-consolidate-without-touching-windows-or-checkpoints
+  (let* ((world (fixture)) (ignored (create-head world "third"))
+         (data (snapshot-world world))
+         (active (find "left" (getf data :heads) :key (lambda (h) (getf h :id)) :test #'equal))
+         (row (find (getf active :active) (getf data :presentations) :key (lambda (p) (getf p :id)) :test #'equal))
+         (duplicate (copy-tree row)) (stale (copy-tree row)))
+    (declare (ignore ignored))
+    (setf (getf duplicate :id) "presentation-900"
+          (getf stale :id) "presentation-901" (getf stale :head) "third")
+    (push duplicate (getf data :presentations))
+    (push stale (getf data :presentations))
+    ;; Version 3 rejects duplicates instead of silently repairing corruption.
+    (signals error (restore-world data))
+    (setf (getf data :version) 2)
+    (let* ((restored (restore-world data)) (after (snapshot-world restored)))
+      (dolist (key '(:clients :activities :views :viewsets :heads))
+        (is (equalp (getf data key) (getf after key))))
+      (is (equalp row (find (getf row :id) (getf after :presentations) :key (lambda (p) (getf p :id)) :test #'equal)))
+      (signals unknown-entity (find-presentation restored "presentation-900"))
+      (is-false (presentation-client-ids (find-presentation restored "presentation-901")))
+      (is-false (presentation-source-view-id (find-presentation restored "presentation-901")))
+      (normalize-activity-arrangements restored)
+      (is (equalp after (snapshot-world restored)))
+      (is-true (validate-world restored)))))
+
+(test worker-copy-does-not-share-mutable-strings
+  (let* ((text (copy-seq "Original")) (data (list :name text :pair (cons :label text)))
+         (copy (copy-data data)))
+    (setf (char text 0) #\X)
+    (is (string= "Original" (getf copy :name)))
+    (is (string= "Original" (cdr (getf copy :pair))))))
+
+(defmacro with-store ((store path) &body body)
+  `(uiop:with-temporary-file (:pathname ,path :prefix "lime-persistence-test-")
+     (delete-file ,path)
+     (let ((,store (open-session-store ,path)))
+       (unwind-protect (progn ,@body)
+         (close-session-store ,store)
+         (let ((lock (pathname (concatenate 'string (namestring ,path) ".lock"))))
+           (when (probe-file lock) (delete-file lock)))))))
+
+(test atomic-private-storage-and-writer-exclusion
+  (with-store (store path)
+    (is-false (read-session-store store))
+    (signals error (open-session-store path))
+    (is (= 1 (logand 1 (cffi:foreign-funcall "fcntl" :int (lime.persistence::session-store-descriptor store) :int 1 :int))))
+    (let ((data (snapshot-world (fixture))))
+      (write-session-store store data)
+      (is (equalp data (read-session-store store)))
+      (is (string= "600" (string-trim '(#\Newline) (uiop:run-program (list "stat" "-c" "%a" (namestring path)) :output :string))))
+      (let ((original (symbol-function 'lime.persistence::%sync-path)))
+        (unwind-protect
+             (progn
+               (setf (symbol-function 'lime.persistence::%sync-path)
+                     (lambda (path) (declare (ignore path)) (error "Injected disk failure")))
+               (signals error (write-session-store store '(:replacement t))))
+          (setf (symbol-function 'lime.persistence::%sync-path) original)))
+      (is (equalp data (read-session-store store))))
+    (close-session-store store)
+    (let ((again (open-session-store path)))
+      (is-true again) (close-session-store again))))
+
+(defvar *read-executed* nil)
+(test reader-does-not-evaluate-or-accept-trailing-truncated-or-circular-data
+  (with-store (store path)
+    (dolist (text '("#.(setf lime.persistence.test::*read-executed* t)"
+                    "#S(LIME.CORE::WORLD)" "#1=(:cycle . #1#)" "(:one 1) (:two 2)"
+                    "(:missing" "" "(:text \"unterminated)"))
+      (with-open-file (stream path :direction :output :if-exists :supersede)
+        (write-string text stream))
+      (signals error (read-session-store store)))
+    (is-false *read-executed*)))
+
+(defun run-tests () (unless (run! 'persistence-suite) (error "Persistence tests failed.")))

test/presentation-navigation.lisp

@@ -0,0 +1,85 @@
+(in-package #:lime.test)
+(in-suite lime-suite)
+
+(defun make-presentation-navigation-fixture ()
+  (let ((w (make-world)))
+    (dolist (id '("left" "right" "third")) (create-head w id))
+    (dolist (id '("work" "chat" "other")) (create-activity w id id))
+    (dolist (row '(("browser" "work") ("terminal" "work") ("discord" "chat")
+                   ("hidden" "chat") ("shared" "chat")))
+      (create-client w (first row) (second row)))
+    (set-client-shared w "shared" t)
+    (create-view w "work/code" "work" "Code" (placements "browser"))
+    (create-view w "chat/chat" "chat" "Chat" (placements "discord" "shared"))
+    (activate-view-strictly w "left" "work/code")
+    (activate-view-strictly w "right" "chat/chat")
+    w))
+
+(test portable-arrangement-swaps-preserve-state-and-lease-identity
+  (let* ((w (make-presentation-navigation-fixture))
+         (work (current-presentation w "left")) (chat (current-presentation w "right"))
+         (leases (mapcar (lambda (id) (lease-for-client w id)) '("browser" "discord" "shared")))
+         (view-before (lime.core::%copy-placements (view-placements (find-view w "chat/chat")))))
+    (set-presentation-layout-mode w (presentation-id chat) :monocle)
+    (let ((report (preflight-presentation-bring w "left" (presentation-id chat)))
+          (before (world-revision w)))
+      (is (activation-report-ready-p report))
+      (is (= before (world-revision w))))
+    (bring-presentation-to-head w (presentation-id chat) "left")
+    (is (eq chat (current-presentation w "left")))
+    (is (eq work (current-presentation w "right")))
+    (is (equal "left" (presentation-head-id chat)))
+    (is (equal "right" (presentation-head-id work)))
+    (is (eq :monocle (presentation-layout-mode chat)))
+    (is (presentation-dirty-p chat))
+    (is (equalp view-before (view-placements (find-view w "chat/chat"))))
+    (is (null (lease-for-client w "hidden")))
+    (loop for id in '("browser" "discord" "shared") for old in leases
+          do (is (eq old (lease-for-client w id))))
+    (dotimes (i 20)
+      (bring-presentation-to-head w (presentation-id chat) (if (evenp i) "right" "left"))
+      (is (validate-world w)))
+    (let ((revision (world-revision w)))
+      (bring-presentation-to-head w (presentation-id chat) "left")
+      (is (= revision (world-revision w))))))
+
+(test swaps-transpose-cached-extended-portions-without-erasing-them
+  (let* ((w (make-presentation-navigation-fixture)) (chat (current-presentation w "right"))
+         (work-left (current-presentation w "left")))
+    (create-view w "work/logs" "work" "Logs" (placements "terminal"))
+    (let ((work-right (activate-view-strictly w "right" "work/logs")))
+      (resume-presentation-strictly w "right" (presentation-id chat))
+      (bring-presentation-to-head w (presentation-id chat) "left")
+      (is (eq work-left (current-presentation w "right")))
+      (is (eq work-right (activity-draft-for-head w "work" "left")))
+      (is (equal '("terminal") (presentation-client-ids work-right)))
+      (is (equal "work/logs" (presentation-source-view-id work-right)))
+      (is (null (lease-for-client w "terminal")))
+      (is (validate-world w))
+      (open-activity-draft w "left" "work")
+      (is (eq work-right (current-presentation w "left")))
+      (is (validate-world w)))))
+
+(test inactive-portable-return-does-not-change-other-displays-or-recall-missing-slots
+  (let* ((w (make-presentation-navigation-fixture)) (chat (current-presentation w "right")))
+    (open-activity-draft w "right" "other")
+    (let ((other (current-presentation w "right")))
+      (bring-presentation-to-head w (presentation-id chat) "left")
+      (is (eq other (current-presentation w "right")))
+      (is (eq chat (current-presentation w "left")))
+      (is (null (lease-for-client w "browser")))
+      (is (null (lease-for-client w "hidden")))
+      (is (validate-world w)))
+    (let ((before (world-revision w)))
+      (signals stale-transition-plan
+        (bring-presentation-to-head w (presentation-id chat) "third" :expected-revision (1- before)))
+      (signals unknown-entity (bring-presentation-to-head w (presentation-id chat) "missing"))
+      (is (= before (world-revision w))))
+    ;; A topology-suspended arrangement is still portable.
+    (commit-head-topology-reconciliation-plan w
+      (build-head-topology-reconciliation-plan
+       (preflight-head-topology-reconciliation w '("right" "third"))))
+    (is (null (presentation-head-id chat)))
+    (bring-presentation-to-head w (presentation-id chat) "third")
+    (is (eq chat (current-presentation w "third")))
+    (is (validate-world w))))

test/ui-package.lisp

@@ -0,0 +1,2 @@
+(defpackage #:lime.ui.test
+  (:use #:cl #:fiveam #:lime.ui))

test/ui.lisp

@@ -0,0 +1,209 @@
+(in-package #:lime.ui.test)
+
+(def-suite lime-ui-suite
+  :description "Renderer-neutral palette session tests.")
+
+(in-suite lime-ui-suite)
+
+(defun candidate (id label &optional detail result)
+  (make-ui-candidate :id id :label label :detail detail
+                     :action (lambda () (or result (ui-close-result)))))
+
+(test direct-search-filters-and-wraps-selection
+  (let ((session (make-ui-session
+                  (list (candidate "code" "Code" "Lime development")
+                        (candidate "play" "Play" "Game")))))
+    (ui-session-handle-key session #\g)
+    (is (equal (mapcar #'ui-candidate-id (ui-session-candidates session))
+               '("play")))
+    (is (= (ui-session-selected-index session) 0))
+    (ui-session-handle-key session :backspace)
+    (ui-session-handle-key session :up)
+    (is (= (ui-session-selected-index session) 1))))
+
+(test direct-search-supports-ordered-fuzzy-program-input
+  (let ((session (make-ui-session
+                  (list (candidate "waterfox" "waterfox")
+                        (candidate "web-browser" "web-browser")
+                        (candidate "terminal" "terminal")))))
+    (dolist (character '(#\w #\t #\f))
+      (ui-session-handle-key session character))
+    (is (equal (mapcar #'ui-candidate-id (ui-session-candidates session))
+               '("waterfox")))))
+
+(test a-candidate-can-replace-the-palette-with-an-explicit-next-step
+  (let* ((follow-up (candidate "take" "Move windows here" nil (ui-close-result)))
+         (session (make-ui-session
+                   (list (candidate "docs" "Docs" "Lime development"
+                                    (ui-replace-result
+                                     (list follow-up)
+                                     "Docs has windows leased on another Head."))))))
+    (let ((result (ui-session-handle-key session :return)))
+      (is (eq (ui-result-kind result) :replace))
+      (is (equal (ui-session-status session)
+                 "Docs has windows leased on another Head."))
+      (is (equal (mapcar #'ui-candidate-id (ui-session-candidates session))
+                 '("take"))))))
+
+(test escape-closes-a-session-without-running-an-action
+  (let ((session (make-ui-session (list (candidate "code" "Code")))))
+    (is (eq (ui-result-kind (ui-session-handle-key session :escape)) :close))))
+
+(test a-candidate-can-collect-a-name-through-a-renderer-neutral-prompt
+  (let ((submitted-name nil))
+    (let ((session
+            (make-ui-session
+             (list
+              (make-ui-candidate
+               :id :new-activity :label "New named Activity..."
+               :action
+               (lambda ()
+                 (ui-prompt-result
+                  "New Activity"
+                  (lambda (name)
+                    (setf submitted-name name)
+                    (ui-close-result "Activity created.")))))))))
+      (is (eq (ui-result-kind (ui-session-handle-key session :return)) :prompt))
+      (is (eq (ui-session-mode session) :prompt))
+      (is (equal (ui-session-prompt session) "New Activity"))
+      (is (eq (ui-result-kind (ui-session-handle-key session :return)) :keep-open))
+    (is (equal (ui-session-status session) "Input is required."))
+      (dolist (character '(#\L #\i #\m #\e))
+        (ui-session-handle-key session character))
+      (is (eq (ui-result-kind (ui-session-handle-key session :return)) :close))
+      (is (equal submitted-name "Lime")))))
+
+(test key-path-mode-navigates-a-tree-and-can-return-to-search
+  (let ((ran-p nil))
+    (let* ((run-node (make-ui-key-node :id :run :key #\r :label "Run"
+                                       :action (lambda ()
+                                                 (setf ran-p t)
+                                                 (ui-close-result))))
+           (tools-node (make-ui-key-node :id :tools :key #\t :label "Tools"
+                                         :children (list run-node)))
+           (session (make-ui-session (list (candidate "search" "Search"))
+                                     :key-path (list tools-node))))
+      (is (eq (ui-result-kind (ui-session-handle-key session :tab)) :keep-open))
+      (is (eq (ui-session-mode session) :key-path))
+      (is (equal (mapcar #'ui-key-node-id (ui-session-key-nodes session))
+                 '(:tools)))
+      (ui-session-handle-key session #\t)
+      (is (equal (mapcar #'ui-key-node-id (ui-session-key-path session))
+                 '(:tools)))
+      (is (equal (mapcar #'ui-key-node-id (ui-session-key-nodes session))
+                 '(:run)))
+      (ui-session-handle-key session :backspace)
+      (is-false (ui-session-key-path session))
+      (is (eq (ui-result-kind (ui-session-handle-key session #\t)) :keep-open))
+      (is (eq (ui-result-kind (ui-session-handle-key session #\r)) :close))
+      (is-true ran-p)
+      (ui-session-handle-key session :tab)
+      (is (eq (ui-session-mode session) :search)))))
+
+(test command-map-can-open-without-a-search-list-or-running-an-action
+  (let* ((runs 0)
+         (leaf (make-ui-key-node :key #\h :label "Hide"
+                                 :action (lambda () (incf runs) (ui-close-result))))
+         (root (make-ui-key-node :key #\w :label "Windows" :children (list leaf)))
+         (session (make-ui-session (list (candidate :all "All commands"))
+                                   :key-path (list root) :mode :key-path)))
+    (is (eq :key-path (ui-session-mode session)))
+    (is (equal (list root) (ui-session-key-nodes session)))
+    (is-false (ui-session-candidates session))
+    (is (eq :keep-open (ui-result-kind (ui-session-handle-key session :return))))
+    (is (= 0 runs))
+    (ui-session-handle-key session #\z)
+    (is (search "not available" (ui-session-status session)))
+    (is (string= "" (ui-session-query session)))
+    (ui-session-handle-key session #\w)
+    (is (equal (list root) (ui-session-key-path session)))
+    (is (equal (list leaf) (ui-session-key-nodes session)))
+    (ui-session-handle-key session :page-down)
+    (is (= 1 (ui-session-key-page session)))
+    (ui-session-handle-key session :backspace)
+    (is (= 0 (ui-session-key-page session)))
+    (is-false (ui-session-key-path session))
+    (ui-session-handle-key session #\w)
+    (is (eq :close (ui-result-kind (ui-session-handle-key session #\h))))
+    (is (= 1 runs))))
+
+(test search-from-the-menu-restores-the-root-catalog-after-a-temporary-picker
+  (let* ((all (candidate :all "All commands"))
+         (choice (candidate :partial "Open partial view"))
+         (leaf (make-ui-key-node :key #\v :label "Views"
+                                :action (lambda () (ui-replace-result (list choice)))))
+         (session (make-ui-session (list all) :key-path (list leaf) :mode :key-path)))
+    (ui-session-handle-key session #\v)
+    (is (eq :search (ui-session-mode session)))
+    (is (string= "Type to filter; Enter to choose; Esc to cancel." (ui-session-status session)))
+    (is (equal (list choice) (ui-session-candidates session)))
+    (ui-session-handle-key session :tab)
+    (is (eq :key-path (ui-session-mode session)))
+    (ui-session-handle-key session #\Space)
+    (is (eq :search (ui-session-mode session)))
+    (is (equal (list all) (ui-session-candidates session)))
+    (ui-session-handle-key session :tab)
+    (ui-session-handle-key session :tab)
+    (is (equal (list all) (ui-session-candidates session)))))
+
+(test a-bound-space-in-a-custom-menu-wins-over-the-search-shortcut
+  (let* ((ran nil)
+         (node (make-ui-key-node :key #\Space :label "Custom command"
+                                 :action (lambda () (setf ran t) (ui-close-result))))
+         (session (make-ui-session nil :key-path (list node) :mode :key-path)))
+    (is (eq :close (ui-result-kind (ui-session-handle-key session #\Space))))
+    (is-true ran)))
+
+(test menu-name-prompts-keep-spaces-and-dont-let-tab-run-a-command
+  (let* ((name nil)
+         (node (make-ui-key-node :key #\n :label "New activity"
+                                 :action (lambda ()
+                                           (ui-prompt-result "Name"
+                                             (lambda (input) (setf name input) (ui-close-result))))))
+         (session (make-ui-session nil :key-path (list node) :mode :key-path)))
+    (ui-session-handle-key session #\n)
+    (is (eq :prompt (ui-session-mode session)))
+    (is (string= "Enter to confirm; Esc to cancel." (ui-session-status session)))
+    (dolist (key '(#\M #\y #\Space #\W #\M)) (ui-session-handle-key session key))
+    (ui-session-handle-key session :tab)
+    (is (eq :prompt (ui-session-mode session)))
+    (is-false name)
+    (is (eq :close (ui-result-kind (ui-session-handle-key session :return))))
+    (is (string= "My WM" name))))
+
+(test search-and-keyless-launcher-sessions-keep-their-old-entry-behavior
+  (let ((session (make-ui-session (list (candidate :terminal "st terminal")))))
+    (is (eq :search (ui-session-mode session)))
+    (ui-session-handle-key session #\s)
+    (ui-session-handle-key session #\Space)
+    (is (string= "s " (ui-session-query session)))
+    (ui-session-handle-key session :tab)
+    (is (eq :search (ui-session-mode session)))
+    (is (eq :close (ui-result-kind (ui-session-handle-key session :escape))))))
+
+(test pointer-candidate-activation-shares-transitions-and-rejects-stale-hits
+  (let* ((runs 0)
+         (choice (make-ui-candidate :label "Choice"
+                                   :action (lambda () (incf runs) (ui-close-result))))
+         (picker (make-ui-candidate :label "Picker"
+                                   :action (lambda () (ui-replace-result (list choice)))))
+         (session (make-ui-session (list picker))))
+    (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session choice))))
+    (is (= 0 runs))
+    (is (eq :replace (ui-result-kind (ui-session-activate-candidate session picker))))
+    (is (equal (list choice) (ui-session-candidates session)))
+    (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session picker))))
+    (is (eq :close (ui-result-kind (ui-session-activate-candidate session choice))))
+    (is (= 1 runs))
+    (ui-session-handle-key session #\z)
+    (is-false (ui-session-candidates session))
+    (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session choice))))
+    (is (= 1 runs))
+    (ui-session-apply-result session (ui-prompt-result "Name" (lambda (name)
+                                                               (declare (ignore name))
+                                                               (ui-close-result))))
+    (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session choice))))
+    (is (eq :prompt (ui-session-mode session)))))
+
+(defun run-tests ()
+  (run! 'lime-ui-suite))

test/x11-activity-navigation.lisp

@@ -0,0 +1,109 @@
+(in-package #:lime.x11.test)
+(in-suite lime-x11-suite)
+
+(test activity-portability-is-default-and-extended-intent-is-sticky
+  (with-membership-backend (backend world)
+    (let ((development (current-presentation world "main")) (chill (current-presentation world "other")))
+      (is (eq :portable (backend-activity-navigation-mode backend "development")))
+      (backend-switch-to-activity backend "chill" :head-id "main")
+      (is (eq chill (current-presentation world "main")))
+      (is (eq development (current-presentation world "other")))
+      (is (equal "main" (x11-backend-focused-head-id backend)))
+      (backend-switch-to-activity backend "development" :head-id "main")
+      (is (eq development (current-presentation world "main")))
+      (backend-extend-activity-to-head backend "development" "other")
+      (is (eq :extended (backend-activity-navigation-mode backend "development")))
+      (is (eq development (current-presentation world "main")))
+      (is (null (presentation-client-ids (current-presentation world "other"))))
+      (backend-switch-to-activity backend "chill" :head-id "other")
+      (is (eq chill (current-presentation world "other")))
+      (is (eq :extended (backend-activity-navigation-mode backend "development")))
+      (let ((snapshot (lime.x11::%activity-navigation-snapshot backend)))
+        (setf (gethash backend lime.x11::*backend-activity-navigation-states*)
+              (lime.x11::%activity-navigation-read-data snapshot world))
+        (is (eq :extended (backend-activity-navigation-mode backend "development"))))
+      (backend-make-activity-portable backend "development" "main")
+      (is (eq :portable (backend-activity-navigation-mode backend "development")))
+      (is (validate-world world)))))
+
+(test old-empty-drafts-do-not-anchor-a-portable-activity-to-a-monitor
+  (with-membership-backend (backend world)
+    (let* ((primary (current-presentation world "main"))
+           (old-empty (open-activity-draft world "other" "development")))
+      (open-activity-draft world "other" "chill")
+      (let ((before (lime.persistence:snapshot-world world)))
+        (is (eq :portable (backend-activity-navigation-mode backend "development")))
+        (is (equalp before (lime.persistence:snapshot-world world))))
+      (backend-switch-to-activity backend "development" :head-id "other")
+      (is (eq primary (current-presentation world "other")))
+      (is (not (eq old-empty (current-presentation world "other"))))
+      (is (= 3 (hash-table-count (lime.core::world-presentations world))))
+      (is (validate-world world))
+      (dotimes (i 10)
+        (backend-switch-to-activity backend "development" :head-id (if (evenp i) "main" "other"))
+        (is (eq :portable (backend-activity-navigation-mode backend "development")))
+        (is (validate-world world))))))
+
+(test explicit-extension-and-collapse-ui-check-stale-contexts
+  (with-membership-backend (backend world)
+    (let* ((result (lime.x11::%ui-extend-activity-result backend))
+           (choice (second (ui-result-candidates result)))
+           (before (lime.persistence:snapshot-world world)))
+      (is (eq :cancel (ui-candidate-id (first (ui-result-candidates result)))))
+      (is (equalp before (lime.persistence:snapshot-world world)))
+      (backend-hide-client backend "editor")
+      (is (eq :keep-open (ui-result-kind (funcall (ui-candidate-action choice)))))
+      (is (eq :portable (backend-activity-navigation-mode backend "development"))))
+    (backend-extend-activity-to-head backend "development" "other")
+    (let ((before (lime.persistence:snapshot-world world)))
+      (signals invalid-transition (backend-make-activity-portable backend "development" "main"))
+      (is (equalp before (lime.persistence:snapshot-world world)))
+      (signals stale-transition-plan
+        (backend-extend-activity-to-head backend "chill" "main" :expected-revision -1))
+      (is (equalp before (lime.persistence:snapshot-world world))))))
+
+(test portable-policy-validation-and-sending-to-suspended-arrangement
+  (with-membership-backend (backend world)
+    (let* ((chill (current-presentation world "other"))
+           (data (lime.x11::%activity-navigation-snapshot backend)))
+      (dolist (bad (list (append data (list (first data)))
+                        '(("development" :unknown nil) ("chill" :portable nil))
+                        `(("development" :portable ,(presentation-id chill)) ("chill" :portable nil))
+                        '(("development" :extended nil))))
+        (signals error (lime.x11::%activity-navigation-read-data bad world)))
+      (commit-head-topology-reconciliation-plan world
+        (build-head-topology-reconciliation-plan (preflight-head-topology-reconciliation world '("main"))))
+      (backend-move-client-to-activity backend "editor" "chill")
+      (is (equal '("editor") (presentation-client-ids chill)))
+      (is (null (lease-for-client world "editor")))
+      (is (eq :portable (backend-activity-navigation-mode backend "chill")))
+      (backend-switch-to-activity backend "chill" :head-id "main")
+      (is (eq chill (current-presentation world "main")))
+      (is (validate-world world)))))
+
+(test portable-checkpoint-recall-preflights-before-moving-any-monitor
+  (with-membership-backend (backend world)
+    (let* ((development (current-presentation world "main"))
+           (chill (current-presentation world "other")))
+      (create-view world "development/alternate" "development" "Alternate"
+                   (list (make-placement :client-id "editor")))
+      (backend-activate-view backend "development/alternate" :head-id "other")
+      (is (eq development (current-presentation world "other")))
+      (is (eq chill (current-presentation world "main")))
+      (is (eq :portable (backend-activity-navigation-mode backend "development")))
+      (is (equal '("editor") (presentation-client-ids development)))
+      (set-client-shared world "terminal" t)
+      (show-client-on-presentation world "terminal" (presentation-id chill))
+      (create-view world "development/contested" "development" "Contested"
+                   (list (make-placement :client-id "terminal")))
+      (let ((before (lime.persistence:snapshot-world world)))
+        (is (not (activation-report-ready-p
+                  (backend-preflight-view-activation backend "development/contested" :head-id "main"))))
+        (signals activation-blocked
+          (backend-activate-view backend "development/contested" :head-id "main"))
+        (is (equalp before (lime.persistence:snapshot-world world))))
+      (backend-activate-view backend "development/contested" :head-id "main" :policy :partial)
+      (is (eq development (current-presentation world "main")))
+      (is (eq chill (current-presentation world "other")))
+      (is (equal "other" (presentation-head-id (find-presentation world (lease-presentation-id (lease-for-client world "terminal"))))))
+      (is (validate-world world)))))

test/x11-appearance-config.lisp

@@ -0,0 +1,8 @@
+(in-package #:cl-user)
+
+;; A standalone smoke fixture, independent of the user's installed config.
+(lime.config:defconfiguration appearance-smoke-config
+  (:options :default-layout :manual)
+  (:bar :height 22)
+  (:appearance :border-width 3 :inner-gap 5 :outer-gap 5
+               :focused-border "#ffac54" :unfocused-border "#121f25"))

test/x11-appearance-smoke.lisp

@@ -0,0 +1,415 @@
+;;;; Opt-in real-X regression test; requires Xvfb and local Lisp dependencies.
+;;;; Run from any directory: sbcl --non-interactive --load /path/to/this/file
+;;;; Uses a fresh server selected by -displayfd, never the current DISPLAY.
+(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))))
+              (display-name (format nil ":~D" number)))
+         (setf backend (lime.x11:start-lime
+                        :display-name display-name :head-discovery :none
+                        :config-file (asdf:system-relative-pathname
+                                      "lime" "test/x11-appearance-config.lisp"))
+               client-display (xlib:open-default-display display-name))
+         (let* ((display (lime.x11::x11-backend-display backend))
+                (root (lime.x11::x11-backend-root backend))
+                (client-root (xlib:screen-root (xlib:display-default-screen client-display)))
+                (windows (loop repeat 3 collect
+                               (xlib:create-window :parent client-root :x 0 :y 0
+                                                   :width 100 :height 100 :border-width 7
+                                                   :background 0)))
+                (ids nil))
+           (labels ((check (truth label)
+                      (assert truth () "Failed: ~A" label)
+                      (incf checks))
+                    (sync () (xlib:display-finish-output display))
+                    (check-single-tile (window)
+                      (sync)
+                      (check (= 0 (xlib:drawable-border-width window)) "single tile border")
+                      (check (= 0 (xlib:drawable-x window)) "single tile x")
+                      (check (= 22 (xlib:drawable-y window)) "single tile keeps bar")
+                      (check (= 1000 (xlib:drawable-width window)) "single tile width")
+                      (check (= 600 (xlib:drawable-height window)) "single tile height"))
+                    (drain-unmap-events ()
+                      ;; This fixture calls commands directly, without the
+                      ;; event loop. Consume real hides from monocle cycling
+                      ;; before testing a later application withdrawal.
+                      (sync)
+                      (loop while
+                            (xlib:event-case (display :timeout 0 :discard-p t)
+                              (:unmap-notify (event-window window configure-p)
+                                (lime.x11::%handle-unmap-notify
+                                 backend event-window window configure-p)
+                                t)
+                              (otherwise () t))))
+                    (pixel-at-border (window)
+                      (sync)
+                      (aref (xlib:image-z-pixarray
+                             (xlib:get-image root :x (xlib:drawable-x window)
+                                             :y (+ 10 (xlib:drawable-y window))
+                                             :width 1 :height 1 :format :z-pixmap)) 0 0))
+                    (border-is (window color)
+                      (check (= (pixel-at-border window)
+                                (lime.x11::%border-pixel backend color)) color)))
+             (xlib:display-finish-output client-display)
+             (xlib:change-property (first windows) :_NET_WM_NAME
+                                   (babel:string-to-octets "Already named" :encoding :utf-8)
+                                   :UTF8_STRING 8)
+             (xlib:display-finish-output client-display)
+             (dolist (window windows)
+               (push (lime.x11:manage-window
+                      backend (find (xlib:window-id window) (xlib:query-tree root)
+                                    :key #'xlib:window-id)) ids)
+               (when (= 1 (length ids))
+                 (check (string= "Already named"
+                                 (lime.x11:icccm-client-info-title
+                                  (lime.x11:backend-client-icccm-info backend (first ids))))
+                        "adoption reads an existing modern title")
+                 ;; First MapRequest in the initial manual draft, then in
+                 ;; master/stack, must already be undecorated.
+                 (check-single-tile window)
+                 (lime.x11:backend-use-master-stack-layout backend)
+                 (check-single-tile window)
+                 (lime.x11:backend-use-manual-layout backend))
+               (when (= 2 (length ids))
+                 (sync)
+                 (check (= 3 (xlib:drawable-border-width (first windows)))
+                        "second MapRequest restores first tile border")
+                 (check (= 3 (xlib:drawable-border-width window))
+                        "second MapRequest decorates new tile")))
+             (setf ids (nreverse ids))
+             (dolist (layout-command (list #'lime.x11:backend-use-manual-layout
+                                          #'lime.x11:backend-use-master-stack-layout))
+               (funcall layout-command backend)
+               (lime.x11:backend-hide-client backend (second ids))
+               (lime.x11:backend-hide-client backend (third ids))
+               (check-single-tile (first windows))
+               (lime.x11:backend-show-client
+                backend (third ids) :kind :float
+                :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))
+               (check-single-tile (first windows))
+               (check (= 3 (xlib:drawable-border-width (third windows)))
+                      "floating overlay keeps border above sole tile")
+               (lime.x11:backend-toggle-client-floating backend (third ids))
+               (sync)
+               (check (= 3 (xlib:drawable-border-width (first windows)))
+                      "unfloating restores tiled border")
+               (check (= 5 (xlib:drawable-x (first windows)))
+                      "unfloating restores outer gap")
+               (lime.x11:backend-hide-client backend (third ids))
+               (lime.x11:backend-show-client backend (second ids))
+               (lime.x11:backend-show-client backend (third ids)))
+             (lime.x11:backend-use-master-stack-layout backend)
+             (sync)
+             ;; Real-font metrics, not an assumed number of pixels per glyph,
+             ;; must position both painted controls and their click regions.
+             (let* ((head-id (first (lime.x11:backend-head-ids backend)))
+                    (bar (gethash head-id (lime.x11::x11-backend-head-bars backend)))
+                    (font (lime.x11::x11-head-bar-font bar))
+                    (bar-window (lime.x11::x11-head-bar-window bar))
+                    (regions (lime.x11::x11-head-bar-hit-regions bar))
+                    (logo-right (+ 10 (lime.x11::%text-width font "Lime")))
+                    (layout-left (+ logo-right (lime.x11::%text-width font " | ")
+                                    (lime.x11::%text-width font
+                                                     (lime.x11::%bar-presentation-label backend head-id))
+                                    (lime.x11::%text-width font " | ")))
+                    (layout-right (+ layout-left (lime.x11::%text-width font "[]=")))
+                    (clicks 0))
+               (check (= logo-right (lime.x11::x11-head-bar-hit-region-right (first regions)))
+                      "logo uses actual font width")
+               (check (= layout-left (lime.x11::x11-head-bar-hit-region-left (third regions)))
+                      "layout follows measured label and separator")
+               (check (= layout-right (lime.x11::x11-head-bar-hit-region-right (third regions)))
+                      "layout click width equals rendered token width")
+               (let* ((activity-region (second regions))
+                      (left (lime.x11::x11-head-bar-hit-region-left activity-region))
+                      (pixels (xlib:image-z-pixarray
+                               (xlib:get-image bar-window :x left :y 0
+                                               :width (- (lime.x11::x11-head-bar-hit-region-right activity-region) left)
+                                               :height 22 :format :z-pixmap))))
+                 (check (loop for i below (array-total-size pixels)
+                              thereis (= (lime.x11::%bar-pixel bar "#ffac54") (row-major-aref pixels i)))
+                        "active Activity text is painted in the accent color"))
+               (let ((pixels (xlib:image-z-pixarray
+                              (xlib:get-image bar-window :x layout-left :y 0
+                                              :width (- layout-right layout-left)
+                                              :height 18 :format :z-pixmap))))
+                 (check (loop for i below (array-total-size pixels)
+                              thereis (= (lime.x11::%bar-pixel bar "#ffdbb0")
+                                         (row-major-aref pixels i)))
+                        "layout text is painted within measured region"))
+               ;; Inspect actual pixels, not only computed drawing positions.
+               (labels ((bar-pixel-at (x)
+                          (sync)
+                          (aref (xlib:image-z-pixarray
+                                 (xlib:get-image bar-window :x x :y 0
+                                                 :width 1 :height 1 :format :z-pixmap)) 0 0))
+                        (bar-image ()
+                          (sync)
+                          (xlib:image-z-pixarray
+                           (xlib:get-image bar-window :x 0 :y 0 :width 1000 :height 22
+                                           :format :z-pixmap)))
+                        (drain-properties ()
+                          (xlib:display-finish-output client-display)
+                          (sync)
+                          (loop while
+                                (xlib:event-case (display :timeout 0 :discard-p t)
+                                  (:property-notify (window atom)
+                                    (lime.x11::%handle-property-notify backend window atom) t)
+                                  (:unmap-notify (event-window window configure-p)
+                                    (lime.x11::%handle-unmap-notify backend event-window window configure-p) t)
+                                  (otherwise () t)))))
+                 (let* ((title-left (+ layout-right 8))
+                        (saved-config (lime.x11:x11-backend-configuration backend))
+                        (alternative (lime.x11::copy-lime-configuration saved-config)))
+                   (check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#40535d"))
+                          "left title edge is the muted color")
+                   (check (= (bar-pixel-at 999) (bar-pixel-at title-left))
+                          "right title edge matches the left")
+                   (check (= (bar-pixel-at (1+ title-left)) (lime.x11::%bar-pixel bar "#121f25"))
+                          "title edge is exactly one pixel")
+                   (check (= (bar-pixel-at 998) (lime.x11::%bar-pixel bar "#121f25"))
+                          "focused title has its own background")
+                   (setf (lime.x11::x11-backend-focused-head-id backend) nil)
+                   (lime.x11::render-head-bars backend)
+                   (check (= (bar-pixel-at 998) (lime.x11::%bar-pixel bar "#0b1216"))
+                          "unfocused title background is quieter")
+                   (check (= (bar-pixel-at 0) (lime.x11::%bar-pixel bar "#060a0c"))
+                          "head focus does not recolor the side sections")
+                   (setf (lime.x11::x11-backend-focused-head-id backend) head-id)
+                   (setf (lime.x11:lime-configuration-bar-style alternative)
+                         (lime.x11:make-head-bar-style :title-edge-color nil))
+                   (lime.x11:apply-lime-configuration backend alternative)
+                   (check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#121f25"))
+                          "configuration can remove title edges live")
+                   (lime.x11:apply-lime-configuration
+                    backend saved-config
+                    :source (namestring (asdf:system-relative-pathname "lime" "test/x11-appearance-config.lisp"))
+                    :name 'cl-user::appearance-smoke-config)
+                   (check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#40535d"))
+                          "restoring configuration repaints title edges"))
+                 (let* ((client (third windows))
+                        (client-id (third ids))
+                        (presentation (lime.core:current-presentation
+                                       (lime.x11::x11-backend-world backend) head-id))
+                        (dirty-before (lime.core:presentation-dirty-p presentation)))
+                   (setf (xlib:wm-name client) "Legacy title")
+                   (drain-properties)
+                   (check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id))
+                          "legacy title notification refreshes the cache")
+                   (let ((before (bar-image)))
+                     (xlib:change-property client :_NET_WM_NAME
+                                           (babel:string-to-octets "café — Editor" :encoding :utf-8)
+                                           :UTF8_STRING 8)
+                     (drain-properties)
+                     (check (string= "café — Editor" (lime.x11::%bar-focused-title backend head-id))
+                            "modern UTF-8 title wins over legacy title")
+                     (check (not (equalp before (bar-image))) "title notification repaints actual bar pixels"))
+                   (xlib:change-property client :_NET_WM_NAME '(255 65) :UTF8_STRING 8)
+                   (drain-properties)
+                   (check (find #\A (lime.x11::%bar-focused-title backend head-id))
+                          "malformed UTF-8 does not lose the remaining title")
+                   (xlib:change-property client :_NET_WM_NAME '(1000) :UTF8_STRING 32)
+                   (drain-properties)
+                   (check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id))
+                          "wrong-format modern title falls back safely")
+                   (xlib:change-property client :_NET_WM_NAME '(65) :STRING 8)
+                   (drain-properties)
+                   (check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id))
+                          "wrong-type modern title falls back safely")
+                   (xlib:change-property client :WM_NAME '(99 97 102 233) :STRING 8)
+                   (xlib:change-property client :_NET_WM_NAME '() :UTF8_STRING 8)
+                   (drain-properties)
+                   (check (string= "café" (lime.x11::%bar-focused-title backend head-id))
+                          "empty modern title falls back to Latin-1 legacy title")
+                   (xlib:delete-property client :_NET_WM_NAME)
+                   (drain-properties)
+                   (check (string= "café" (lime.x11::%bar-focused-title backend head-id))
+                          "deleting modern title immediately restores legacy title")
+                   (xlib:delete-property client :_NET_WM_NAME)
+                   (xlib:delete-property client :WM_NAME)
+                   (xlib:set-wm-class client "editor" "ExampleEditor")
+                   (drain-properties)
+                   (check (string= "ExampleEditor" (lime.x11::%bar-focused-title backend head-id))
+                          "title deletion falls back to class, not XID")
+                   (check (eq :normal (lime.x11:icccm-client-info-wm-state
+                                      (lime.x11:backend-client-icccm-info backend client-id)))
+                          "title updates preserve renderer WM_STATE")
+                   (check (eql dirty-before (lime.core:presentation-dirty-p presentation))
+                          "title refresh never dirties the draft")))
+               ;; Check right alignment and real dispatch of segment hits.
+               (lime.x11:backend-set-head-bar-status-providers
+                backend (list (lambda (ignored-backend ignored-head)
+                                (declare (ignore ignored-backend ignored-head))
+                                (list (lime.x11:make-head-bar-segment
+                                       :text "Music" :click-action
+                                       (lambda (&rest ignored) (declare (ignore ignored)) (incf clicks)))
+                                      (lime.x11:make-head-bar-segment :text "20:00")))))
+               (sync)
+               (let* ((status-left (- 1000 10 (lime.x11::%text-width font "Music | 20:00")))
+                      (status-right (+ status-left (lime.x11::%text-width font "Music")))
+                      (region (car (last (lime.x11::x11-head-bar-hit-regions bar)))))
+                 (check (= status-left (lime.x11::x11-head-bar-hit-region-left region))
+                        "status right alignment uses actual font")
+                 (check (= status-right (lime.x11::x11-head-bar-hit-region-right region))
+                        "status click excludes separator")
+                 (let* ((separator-width (lime.x11::%text-width font " | "))
+                        (expected (lime.x11::%make-ui-canvas separator-width 22))
+                        (pixels (xlib:image-z-pixarray
+                                (xlib:get-image bar-window :x status-right :y 0
+                                                :width separator-width
+                                                :height 22 :format :z-pixmap))))
+                   ;; Thin antialiased strokes need not contain a fully opaque
+                   ;; foreground pixel. Compare the whole expected paint instead.
+                   (unwind-protect
+                        (progn
+                          (lime.x11::%canvas-rectangle expected 0 0 separator-width 22 "#060a0c")
+                          (lime.x11::%canvas-text expected font " | " 0 0 separator-width 22 "#b88755"
+                                                 :baseline (lime.x11::%font-centered-baseline font 22))
+                          (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface expected))
+                          (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface expected)))
+                                (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface expected))))
+                            (check (loop for y below 22 always
+                                         (loop for x below separator-width always
+                                               (= (aref pixels y x)
+                                                  (logand #xffffff (cffi:mem-ref data :uint32
+                                                                               (+ (* y stride) (* x 4)))))))
+                                   "status delimiter has its own antialiased color")))
+                     (lime.x11::%free-ui-canvas expected)))
+                 (lime.x11::%handle-head-bar-button-press backend bar-window status-left 5 1 0 0)
+                 (check (= 1 clicks) "status text dispatches click")
+                 (lime.x11::%handle-head-bar-button-press backend bar-window status-right 5 1 0 0)
+                 (check (= 1 clicks) "separator does not dispatch click"))
+               (lime.x11:backend-set-head-bar-status-providers backend nil)
+               (lime.x11:backend-focus-client backend (third ids)))
+             (check (= 3 (xlib:drawable-border-width (first windows))) "actual border width")
+             (check (= 5 (xlib:drawable-x (first windows))) "left gap")
+             (check (= 27 (xlib:drawable-y (first windows))) "bar and top gap")
+             (check (= 5 (- (xlib:drawable-x (second windows))
+                            (+ (xlib:drawable-x (first windows))
+                               (xlib:drawable-width (first windows)) 6))) "column gap")
+             (check (= 5 (- (xlib:drawable-y (third windows))
+                            (+ (xlib:drawable-y (second windows))
+                               (xlib:drawable-height (second windows)) 6))) "row gap")
+             (border-is (first windows) "#121f25")
+             (border-is (third windows) "#ffac54")
+             (lime.x11:backend-focus-client backend (first ids))
+             (lime.x11:backend-use-monocle-layout backend)
+             (sync)
+             (check (= 0 (xlib:drawable-border-width (first windows))) "monocle border")
+             (check (= 0 (xlib:drawable-x (first windows))) "monocle x")
+             (check (= 22 (xlib:drawable-y (first windows))) "monocle keeps bar")
+             (check (= 1000 (xlib:drawable-width (first windows))) "monocle width")
+             (check (= 600 (xlib:drawable-height (first windows))) "monocle height")
+             (lime.x11:backend-focus-client backend (second ids))
+             (sync)
+             (check (= 0 (xlib:drawable-border-width (second windows))) "cycled monocle border")
+             (lime.x11:backend-focus-client backend (first ids))
+             (lime.x11:backend-use-master-stack-layout backend)
+             (sync)
+             (check (= 3 (xlib:drawable-border-width (first windows))) "restore tiled border")
+             (check (= 5 (xlib:drawable-x (first windows))) "restore tiled gap")
+             (border-is (first windows) "#ffac54")
+             (border-is (third windows) "#121f25")
+             (lime.x11:backend-focus-head-background backend (first (lime.x11:backend-head-ids backend)))
+             (border-is (first windows) "#121f25")
+             (lime.x11:backend-focus-client backend (first ids))
+             (lime.x11:backend-set-client-fullscreen backend (first ids) t)
+             (sync)
+             (check (= 0 (xlib:drawable-border-width (first windows))) "fullscreen border")
+             (check (= 0 (xlib:drawable-x (first windows))) "fullscreen x")
+             (check (= 0 (xlib:drawable-y (first windows))) "fullscreen y")
+             (check (= 1000 (xlib:drawable-width (first windows))) "fullscreen width")
+             (check (= 622 (xlib:drawable-height (first windows))) "fullscreen height")
+             (lime.x11:backend-set-client-fullscreen backend (first ids) nil)
+             (sync)
+             (check (= 3 (xlib:drawable-border-width (first windows))) "restore border")
+             (border-is (first windows) "#ffac54")
+             ;; Exercise a failed install after it already repainted windows.
+             (let* ((old (lime.x11:x11-backend-configuration backend))
+                    (bad (lime.x11::copy-lime-configuration old))
+                    (failed nil))
+               (setf (lime.x11:lime-configuration-bar-style bad)
+                     (lime.x11:make-head-bar-style :focused-background "#112233"
+                                                   :title-edge-color "#abcdef")
+                     (lime.x11:lime-configuration-appearance bad)
+                     (lime.x11:make-window-appearance :border-width 9
+                                                     :focused-border "#123456"
+                                                     :unfocused-border "#abcdef")
+                     (lime.x11:lime-configuration-startup-hooks bad)
+                     (list (lambda (ignored) (declare (ignore ignored))
+                             (error "Deliberate rollback test"))))
+               (handler-case
+                   (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t)
+                 (error () (setf failed t)))
+               (check failed "rollback condition")
+               (check (eq old (lime.x11:x11-backend-configuration backend)) "old config restored")
+               (sync)
+               (let* ((head-id (first (lime.x11:backend-head-ids backend)))
+                      (bar (gethash head-id (lime.x11::x11-backend-head-bars backend)))
+                      (window (lime.x11::x11-head-bar-window bar))
+                      (pixels (xlib:image-z-pixarray
+                               (xlib:get-image window :x 998 :y 0 :width 2 :height 1
+                                               :format :z-pixmap))))
+                 (check (= (aref pixels 0 0) (lime.x11::%bar-pixel bar "#121f25"))
+                        "failed config restores previous title background")
+                 (check (= (aref pixels 0 1) (lime.x11::%bar-pixel bar "#40535d"))
+                        "failed config restores previous title edge")
+                 (check (null (gethash "#112233" (lime.x11::x11-head-bar-colors bar)))
+                        "rollback releases unused bar colors"))
+               (check (= 3 (xlib:drawable-border-width (first windows))) "rollback geometry")
+               (border-is (first windows) "#ffac54")
+               (check (= 2 (hash-table-count (lime.x11::x11-backend-border-colors backend)))
+                      "unused colors released"))
+             ;; A successful install and a file reload repaint existing clients.
+             (let ((new (lime.x11::copy-lime-configuration
+                         (lime.x11:x11-backend-configuration backend))))
+               (setf (lime.x11:lime-configuration-appearance new)
+                     (lime.x11:make-window-appearance :border-width 2 :outer-gap 10
+                                                     :inner-gap 8 :focused-border "#00ff00"))
+               (lime.x11:apply-lime-configuration
+                backend new :source (lime.x11:x11-backend-configuration-source backend)
+                            :name (lime.x11:x11-backend-configuration-name backend))
+               (sync)
+               (check (= 2 (xlib:drawable-border-width (first windows))) "live width update")
+               (check (= 10 (xlib:drawable-x (first windows))) "live gap update")
+               (border-is (first windows) "#00ff00"))
+             (lime.x11:reload-backend-configuration backend)
+             (sync)
+             (check (= 3 (xlib:drawable-border-width (first windows))) "file reload border")
+             (check (= 5 (xlib:drawable-x (first windows))) "file reload gap")
+             (border-is (first windows) "#ffac54")
+             (lime.x11:backend-toggle-focused-client-floating
+              backend :data '(:x 0 :y 0 :width 1/3 :height 1/3))
+             (sync)
+             (check (= 3 (xlib:drawable-border-width (first windows))) "float border")
+             (check (= 0 (xlib:drawable-x (first windows))) "float no gap")
+             (check (= 22 (xlib:drawable-y (first windows))) "float work area")
+             ;; Withdrawal restores app-owned width before forgetting it.
+             (drain-unmap-events)
+             (xlib:unmap-window (first windows))
+             (xlib:display-finish-output client-display)
+             (lime.x11::%handle-unmap-notify
+              backend root
+              (gethash (first ids) (lime.x11::x11-backend-client-windows backend)) nil)
+             (sync)
+             (check (= 7 (xlib:drawable-border-width (first windows))) "withdrawal original width")
+             (lime.x11:stop-backend backend)
+             (setf backend nil)
+             ;; Roundtrip on the other connection after WM disconnect.
+             (xlib:display-finish-output client-display)
+             (dolist (window (rest windows))
+               (check (= 7 (xlib:drawable-border-width window)) "shutdown original width"))
+             (format t "~&Live X11 appearance smoke: ~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)))

test/x11-attention-smoke.lisp

@@ -0,0 +1,233 @@
+;;;; 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)))

test/x11-attention.lisp

@@ -0,0 +1,149 @@
+(in-package #:lime.x11.test)
+(in-suite lime-x11-suite)
+
+(test attention-sources-are-independent-live-metadata
+  (let* ((backend (make-head-bar-fixture))
+         (world (x11-backend-world backend))
+         (snapshot (lime.persistence:snapshot-world world)))
+    (is-false (backend-attention-client-ids backend))
+    (lime.x11::%attention-set-source backend "browser" 1 t)
+    (lime.x11::%attention-set-source backend "browser" 2 t)
+    (is (equal '("browser") (backend-attention-client-ids backend)))
+    (lime.x11::%attention-set-source backend "browser" 2 nil)
+    (is-true (backend-client-needs-attention-p backend "browser"))
+    (lime.x11::%attention-set-source backend "terminal" 2 t)
+    (is (equal '("browser" "terminal") (backend-attention-client-ids backend)))
+    (is (equal '("browser" "terminal")
+               (backend-attention-client-ids backend :activity-id "development")))
+    (is-false (backend-attention-client-ids backend :activity-id "other"))
+    (is (equal snapshot (lime.persistence:snapshot-world world)))
+    (lime.x11::%attention-set-source backend "browser" 1 nil)
+    (is-false (backend-client-needs-attention-p backend "browser"))
+    (is-false (gethash "browser" (lime.x11::x11-backend-attention-clients backend)))))
+
+(test attention-bar-and-picker-use-cached-data
+  (let* ((backend (make-head-bar-fixture))
+         (info (lime.x11::make-icccm-client-info :title "日本語 browser")))
+    (is-false (lime.x11::%bar-attention-segment backend))
+    (setf (gethash "browser" (lime.x11::x11-backend-icccm-clients backend)) info)
+    (lime.x11::%attention-set-source backend "browser" 1 t)
+    (let ((segment (lime.x11::%bar-attention-segment backend))
+          (candidate (first (lime.x11::%ui-attention-candidates backend))))
+      (is (eq :attention (head-bar-segment-id segment)))
+      (is (string= "! 1" (head-bar-segment-text segment)))
+      (is (functionp (head-bar-segment-click-action segment)))
+      (is (string= "Development: 日本語 browser" (ui-candidate-label candidate)))
+      (is (equal '(:attend-client "browser") (ui-candidate-id candidate)))
+      (is (string= "! Show: 日本語 browser"
+                   (ui-candidate-label (first (lime.x11::%ui-hidden-client-candidates backend)))))
+      (is (search "! 1" (ui-candidate-detail (first (lime.x11::%ui-activity-candidates backend)))))
+      ;; A cancelled request leaves a stale menu entry safe and non-mutating.
+      (lime.x11::%attention-set-source backend "browser" 1 nil)
+      (is (eq :keep-open (ui-result-kind (funcall (ui-candidate-action candidate))))))
+    (let* ((window (find :window (lime.x11::%ui-key-path backend) :key #'ui-key-node-id))
+           (attention (find :attention (ui-key-node-children window) :key #'ui-key-node-id)))
+      (is (char= #\a (ui-key-node-key attention))))))
+
+(test attention-acknowledgement-requires-selected-visible-input-target
+  (let* ((backend (make-head-bar-fixture))
+         (info (lime.x11::make-icccm-client-info :wm-state :normal)))
+    (setf (gethash "editor" (lime.x11::x11-backend-icccm-clients backend)) info)
+    (is-true (lime.x11::%attention-selected-client-p backend "editor"))
+    (is-false (lime.x11::%attention-selected-client-p backend "terminal"))
+    (setf (lime.x11::x11-backend-focus-root-override-p backend) t)
+    (is-false (lime.x11::%attention-selected-client-p backend "editor"))
+    (setf (lime.x11::x11-backend-focus-root-override-p backend) nil
+          (lime.x11::x11-backend-ui-session backend) (make-ui-session nil))
+    (is-false (lime.x11::%attention-selected-client-p backend "editor"))
+    (setf (lime.x11::x11-backend-ui-session backend) nil
+          (lime.x11::icccm-client-info-wm-state info) :iconic)
+    (is-false (lime.x11::%attention-selected-client-p backend "editor"))
+    (setf (lime.x11::icccm-client-info-wm-state info) :normal
+          (icccm-client-info-accepts-input-p info) nil)
+    (is-false (lime.x11::%attention-selected-client-p backend "editor"))))
+
+(test attention-style-is-user-owned-and-validated
+  (let* ((configuration (symbol-value (eval '(lime.config:defconfiguration attention-test-config
+                               (:options :default-keybindings nil)
+                               (:bar :attention-color "#abcdef" :attention-marker "*"
+                                     :attention-indicator-p nil)))))
+         (style (lime-configuration-bar-style configuration))
+         (backend (make-head-bar-fixture)))
+    (is (string= "#abcdef" (head-bar-style-attention-color style)))
+    (is (string= "*" (head-bar-style-attention-marker style)))
+    (is-false (head-bar-style-attention-indicator-p style))
+    (setf (lime.x11::x11-backend-configuration backend) configuration)
+    (lime.x11::%attention-set-source backend "browser" 1 t)
+    (is-false (lime.x11::%bar-attention-segment backend))
+    (is (= 1 (length (backend-attention-client-ids backend))))
+    (setf (head-bar-style-attention-indicator-p style) t)
+    (is (string= "* 1" (head-bar-segment-text (lime.x11::%bar-attention-segment backend))))
+    (dolist (bad (list (make-head-bar-style :attention-color "bad")
+                      (make-head-bar-style :attention-marker "")
+                      (make-head-bar-style :attention-marker (string #\Newline))
+                      (make-head-bar-style :attention-indicator-p 1)))
+      (signals invalid-transition (lime.x11::%validate-head-bar-style bad)))))
+
+(test attention-visits-respect-collisions-and-stale-choices
+  (dolist (policy '(:partial :take))
+    (declare (ignorable policy))
+    (let* ((backend (make-head-bar-fixture))
+           (world (x11-backend-world backend))
+           (render 'lime.x11:apply-active-presentation)
+           (old-render (symbol-function render)))
+      (setf (gethash "other" (lime.x11::x11-backend-heads backend))
+            (make-x11-head :head-id "other" :x 840 :y 30 :width 800 :height 600)
+            (lime.x11::x11-backend-head-ids backend) '("main" "other"))
+      (create-head world "other")
+      (open-activity-draft world "other" "development")
+      (unwind-protect
+           (progn
+             (setf (symbol-function render) (lambda (b) b))
+             (backend-activate-activity backend "development")
+             (backend-start-activity backend "chill" "Chill")
+             (backend-show-client backend "terminal" :head-id "other")
+             (backend-select-head backend "main")
+             (lime.x11::%attention-set-source backend "browser" 1 t)
+             (let* ((revision (world-revision world))
+                    (candidate (find (list :attend-client "browser")
+                                     (lime.x11::%ui-attention-candidates backend)
+                                     :key #'ui-candidate-id :test #'equal)))
+               (is-true candidate)
+               (is (= revision (world-revision world)))
+               ;; Request cancelled while choosing: no incidental task switch.
+               (lime.x11::%attention-set-source backend "browser" 1 nil)
+               (is (eq :keep-open (ui-result-kind (funcall (ui-candidate-action candidate)))))
+               (is (= revision (world-revision world)))
+               (lime.x11::%attention-set-source backend "browser" 1 t)
+               (is (eq :close (ui-result-kind (funcall (ui-candidate-action candidate)))))
+               (is (equal "browser" (presentation-focus-client-id (current-presentation world "main"))))
+               (is (equal "other"
+                          (lime.x11::ewmh-active-head-id-for-client backend "terminal")))
+               (is (equal '("editor" "terminal")
+                          (mapcar #'placement-client-id (view-placements (find-view world "development/code")))))))
+        (setf (symbol-function render) old-render)))))
+
+(test attention-reclaims-only-the-requested-available-slot
+  (let* ((backend (make-head-bar-fixture))
+         (world (x11-backend-world backend))
+         (source (current-presentation world "main"))
+         (render 'lime.x11:apply-active-presentation)
+         (old-render (symbol-function render)))
+    (setf (gethash "other" (lime.x11::x11-backend-heads backend))
+          (make-x11-head :head-id "other" :x 840 :y 30 :width 800 :height 600)
+          (lime.x11::x11-backend-head-ids backend) '("main" "other"))
+    (create-head world "other")
+    (let ((other (open-activity-draft world "other" "development")))
+      (unwind-protect
+           (progn
+             (setf (symbol-function render) (lambda (b) b))
+             (dolist (id '("editor" "terminal"))
+               (backend-show-client-taking backend id :head-id "other")
+               (hide-client-from-presentation world id (presentation-id other)))
+             (is-false (presentation-client-ids source))
+             (backend-select-head backend "main")
+             (backend-attend-client backend "editor")
+             (is (equal '("editor") (presentation-client-ids source)))
+             (is-false (lease-for-client world "terminal"))
+             (is (equal "editor" (presentation-focus-client-id source))))
+        (setf (symbol-function render) old-render)))))

test/x11-cursor-smoke.lisp

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

test/x11-cursor.lisp

@@ -0,0 +1,36 @@
+(in-package #:lime.x11.test)
+
+(in-suite lime-x11-suite)
+
+(test cursor-configuration-validates-before-touching-x
+  (let ((config (make-lime-configuration)))
+    (is (typep (lime-configuration-cursor config) 'ui-cursor-style))
+    (dolist (theme '(nil :core "Adwaita" "Bibata-Original-Ice"))
+      (setf (lime-configuration-cursor config) (make-ui-cursor-style :theme theme :size 24))
+      (is (eq config (lime.x11::%validate-lime-configuration config))))
+    (dolist (theme (list "" " " :unknown 4 (string #\Null)))
+      (setf (lime-configuration-cursor config) (make-ui-cursor-style :theme theme))
+      (signals invalid-transition (lime.x11::%validate-lime-configuration config)))
+    (dolist (size '(0 -1 7 257 24.0 "24"))
+      (setf (lime-configuration-cursor config) (make-ui-cursor-style :size size))
+      (signals invalid-transition (lime.x11::%validate-lime-configuration config)))
+    (let ((dsl (find-lime-configuration
+                (eval '(lime.config:defconfiguration cursor-fixture
+                         (:cursor :theme "Adwaita" :size (+ 16 8)))))))
+      (is (string= "Adwaita" (ui-cursor-style-theme (lime-configuration-cursor dsl))))
+      (is (= 24 (ui-cursor-style-size (lime-configuration-cursor dsl)))))
+    (signals error (macroexpand-1 '(lime.config:defconfiguration duplicate (:cursor) (:cursor))))
+    (signals error (macroexpand-1 '(lime.config:defconfiguration unknown (:cursor :unknown 2))))))
+
+(test cursor-system-defaults-and-explicit-overrides
+  (flet ((resolve (style &rest defaults)
+           (multiple-value-list (apply #'lime.x11::%resolve-cursor-settings style defaults))))
+    (is (equal '("default" 24) (resolve (make-ui-cursor-style) nil nil nil nil nil)))
+    (is (equal '("Adwaita" 32) (resolve (make-ui-cursor-style) nil nil "Adwaita" "32" nil)))
+    (is (equal '("env-theme" 48) (resolve (make-ui-cursor-style) "env-theme" "48" "resource-theme" "32" nil)))
+    (is (equal '("explicit" 24) (resolve (make-ui-cursor-style :theme "explicit" :size 24)
+                                        "env-theme" "48" "resource-theme" "32" "192")))
+    (is (equal '(:core 24) (resolve (make-ui-cursor-style :theme :core :size 24)
+                                   "env-theme" "48" "resource-theme" "32" nil)))
+    (is (equal '("default" 43) (resolve (make-ui-cursor-style) "" "bad" nil "0" "192")))
+    (is (equal '("default" 24) (resolve (make-ui-cursor-style) nil "999999" nil "-32" "bad")))))

test/x11-default-layout-config.lisp

@@ -0,0 +1,16 @@
+(in-package #:cl-user)
+
+(defvar *default-layout-smoke-loads* 0)
+(defvar *default-layout-smoke-startups* 0)
+(incf *default-layout-smoke-loads*)
+
+(lime.config:defconfiguration default-layout-smoke-config
+  (:options :default-layout :monocle)
+  (:startup
+   (lambda (backend)
+     (dolist (head (lime.x11:backend-head-ids backend))
+       (assert (eq :monocle
+                   (lime.core:presentation-layout-mode
+                    (lime.core:current-presentation
+                     (lime.x11::x11-backend-world backend) head)))))
+     (incf *default-layout-smoke-startups*))))

test/x11-default-layout-smoke.lisp

@@ -0,0 +1,91 @@
+;;;; Run with sbcl --non-interactive --load test/x11-default-layout-smoke.lisp.
+;;;; Owns an isolated Xvfb; never connects to the user's desktop.
+(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" "1000x600x24" "-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))))
+              (display-name (format nil ":~D" number))
+              (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 500 :height 600)
+                           (lime.x11:make-x11-head :head-id "right" :x 500 :y 0 :width 500 :height 600))))
+         (labels ((check (truth label)
+                    (assert truth () "Failed: ~A" label)
+                    (incf checks))
+                  (world () (lime.x11::x11-backend-world backend))
+                  (current (&optional (head "left")) (lime.core:current-presentation (world) head))
+                  (mode (&optional (head "left")) (lime.core:presentation-layout-mode (current head))))
+           ;; Clients that precede the WM must be adopted into master/stack,
+           ;; not briefly seeded into a permanent manual draft.
+           (setf client-display (xlib:open-default-display display-name))
+           (let* ((root (xlib:screen-root (xlib:display-default-screen client-display)))
+                  (windows (loop repeat 3 collect
+                                 (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100))))
+             (dolist (window windows) (xlib:map-window window))
+             (xlib:display-finish-output client-display)
+             (setf backend (lime.x11:start-lime :display-name display-name :heads heads
+                                              :head-bar-height 0 :install-default-keybindings-p nil))
+             (check (eq :master-stack (mode)) "default bootstrap left")
+             (check (eq :master-stack (mode "right")) "default bootstrap right")
+             (check (null (lime.core:activity-view-ids (lime.core:find-activity (world) "scratch")))
+                    "startup does not create saved views")
+             (check (= 3 (length (lime.core:presentation-client-ids (current)))) "three adopted clients")
+             (check (= 300 (xlib:drawable-width (first windows))) "master occupies 3/5 of head")
+             (check (= 200 (xlib:drawable-width (second windows))) "stack occupies 2/5 of head")
+             (check (= 300 (xlib:drawable-height (third windows))) "stack subdivides vertically")
+             (lime.x11:backend-adjust-master-stack-ratio backend 1/20)
+             (check (= 13/20 (getf (lime.core:presentation-layout-options (current)) :master-ratio))
+                    "initial options support resize commands")
+             (lime.x11:backend-use-manual-layout backend)
+             (lime.x11:backend-save-view backend "manual" "Manual")
+             (let ((before (current)))
+               (lime.x11:apply-lime-configuration
+                backend (lime.x11:make-lime-configuration :default-layout :monocle))
+               (check (eq before (current)) "configuration retains existing draft object")
+               (check (eq :manual (mode)) "configuration retains current layout")
+               (check (eq :master-stack (mode "right")) "configuration retains other head layout"))
+             (lime.x11:backend-start-activity backend "chill" "Chill")
+             (check (eq :monocle (mode)) "new activity follows configured default")
+             (lime.x11:backend-use-master-stack-layout backend)
+             (lime.x11:backend-activate-activity backend "scratch" :view-id "manual")
+             (check (eq :manual (mode)) "saved view keeps manual layout")
+             (lime.x11:backend-activate-activity backend "chill")
+             (check (eq :master-stack (mode)) "returning to draft retains layout choice")
+             (let ((report (lime.x11:backend-preflight-activity-activation backend "chill" :head-id "right")))
+               (check (eq :monocle (lime.core:activation-report-desired-layout-mode report))
+                      "first visit on another head preflights default"))
+             (lime.x11:backend-activate-activity backend "chill" :head-id "right")
+             (check (eq :monocle (mode "right")) "first visit on another head uses default")
+             (check (lime.core:validate-world (world)) "world invariants after switches"))
+           (lime.x11:stop-backend backend)
+           (setf backend nil)
+           (xlib:close-display client-display)
+           (setf client-display nil)
+           ;; The file must be evaluated once, before initial drafts exist.
+           ;; Its layout overrides an explicitly conflicting startup keyword.
+           (setf backend
+                 (lime.x11:start-lime
+                  :display-name display-name :heads heads :head-bar-height 0
+                  :default-layout :manual
+                  :config-file (asdf:system-relative-pathname "lime" "test/x11-default-layout-config.lisp")))
+           (check (eq :monocle (mode)) "config layout applied at startup")
+           (check (eq :monocle (mode "right")) "config layout applied on both heads")
+           (check (= 1 (symbol-value '*default-layout-smoke-loads*)) "config evaluated once")
+           (check (= 1 (symbol-value '*default-layout-smoke-startups*)) "startup hook executed once")
+           (lime.x11:backend-use-manual-layout backend)
+           (lime.x11:reload-backend-configuration backend)
+           (check (eq :manual (mode)) "file reload preserves current layout")
+           (check (= 2 (symbol-value '*default-layout-smoke-loads*)) "reload reads the same file")
+           (check (= 1 (symbol-value '*default-layout-smoke-startups*)) "reload skips startup hooks")
+           (lime.x11:backend-start-activity backend "after-reload" "After reload")
+           (check (eq :monocle (mode)) "new drafts after reload follow config")
+           (check (lime.core:validate-world (world)) "final world invariants")
+           (format t "~&Live X11 default-layout smoke: ~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)))

test/x11-fixed-size-smoke.lisp

@@ -0,0 +1,143 @@
+;;;; Fixed-size adoption via real MapRequest/PropertyNotify on an owned Xvfb.
+;;;; Run with sbcl --non-interactive --load test/x11-fixed-size-smoke.lisp.
+;;;; Never connects to the user's DISPLAY or launches Discord itself.
+(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" "2000x622x24" "-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))
+               (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 1000 :height 622)
+                            (lime.x11:make-x11-head :head-id "right" :x 1000 :y 0 :width 1000 :height 622))))
+          (setf clients (xlib:open-default-display display-name)
+                backend (lime.x11:start-lime :display-name display-name :heads heads
+                                             :install-default-keybindings-p nil))
+          (setf (lime.x11::x11-backend-window-appearance backend)
+                (lime.x11:make-window-appearance :border-width 3 :inner-gap 5 :outer-gap 5))
+          (let ((root (xlib:screen-root (xlib:display-default-screen clients)))
+                (fixed (xlib:make-wm-size-hints :min-width 300 :max-width 300
+                                               :min-height 200 :max-height 200)))
+            (labels ((check (truth label) (assert truth () "Fixed-size: ~A" label) (incf checks))
+                     (world () (lime.x11:x11-backend-world backend))
+                     (current (head) (lime.core:current-presentation (world) head))
+                     (id (window) (lime.x11::%backend-client-id backend window))
+                     (kind (window &optional (head "left"))
+                       (lime.core:placement-kind
+                        (find (id window) (lime.core:presentation-placements (current head))
+                              :key #'lime.core:placement-client-id :test #'equal)))
+                     (pump ()
+                       (xlib:display-finish-output clients)
+                       (let ((turns 0) (display (lime.x11::x11-backend-display backend)))
+                         (lime.x11:run-event-loop
+                          backend :timeout 0.005
+                          :before-event (lambda (b)
+                                          (assert (< (incf turns) 400) () "Fixed-size event queue did not settle.")
+                                          (xlib:display-finish-output display)
+                                          (unless (xlib:event-listen display)
+                                            (setf (lime.x11::x11-backend-running-p b) nil))))))
+                     (spawn (&key hints (class "discord") type parent)
+                       (let ((window (xlib:create-window :parent root :x 17 :y 37
+                                                        :width 300 :height 200 :background 0)))
+                         (xlib:set-wm-class window class class)
+                         (when hints (setf (xlib:wm-normal-hints window) hints))
+                         (when type
+                           (xlib:change-property window :_NET_WM_WINDOW_TYPE
+                                                 (list (xlib:intern-atom clients type)) :ATOM 32))
+                         (when parent
+                           (xlib:change-property window :WM_TRANSIENT_FOR
+                                                 (list (xlib:window-id parent)) :WINDOW 32))
+                         (xlib:map-window window)
+                         (pump)
+                         (check (id window) "MapRequest adopted client")
+                         (check (eq :viewable (xlib:window-map-state window)) "client is visible")
+                         window))
+                     (destroy (window) (xlib:destroy-window window) (pump))
+                     (check-full-tile (window)
+                       (check (equal '(0 22 1000 600 0)
+                                     (list (xlib:drawable-x window) (xlib:drawable-y window)
+                                           (xlib:drawable-width window) (xlib:drawable-height window)
+                                           (xlib:drawable-border-width window)))
+                              "sole browser tile retains entire work area without gaps/borders")))
+              (lime.x11:backend-select-head backend "left")
+              (let* ((browser (spawn :class "Browser"))
+                     (popup (spawn :hints fixed)))
+                (check (eq :tile (kind browser)) "ordinary browser is tiled")
+                (check (eq :float (kind popup)) "untyped fixed-size startup window floats")
+                (check (equal '(:normal) (lime.x11::ewmh-client-window-types backend (id popup)))
+                       "float does not depend on an EWMH splash type")
+                (check-full-tile browser)
+                (check (equal '(350 222 300 200 3)
+                              (list (xlib:drawable-x popup) (xlib:drawable-y popup)
+                                    (xlib:drawable-width popup) (xlib:drawable-height popup)
+                                    (xlib:drawable-border-width popup)))
+                       "popup preserves fixed content size, centers in work area, and keeps border")
+                (check (= (xlib:window-id popup) (xlib:window-id (xlib:input-focus clients)))
+                       "new popup receives real X focus")
+                ;; The focused Head, not the global root center, owns the popup.
+                (lime.x11:backend-select-head backend "right")
+                (let ((other (spawn :hints fixed)))
+                  (check (eq :float (kind other "right")) "popup follows selected Head")
+                  (check (= 1350 (xlib:drawable-x other)) "right popup centers in right work area")
+                  (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend (id other)))
+                         "popup has one lease on right Head")
+                  (check-full-tile browser)
+                  (destroy other))
+                (lime.x11:backend-select-head backend "left")
+                ;; A user can retile it. Subsequent hints must not undo that.
+                (lime.x11:backend-toggle-client-floating backend (id popup))
+                (setf (xlib:wm-normal-hints popup) (xlib:make-wm-size-hints :min-width 100 :min-height 100))
+                (pump)
+                (check (eq :tile (kind popup)) "manual retile survives resizable hints")
+                (setf (xlib:wm-normal-hints popup) fixed)
+                (pump)
+                (check (eq :tile (kind popup)) "later fixed hints do not reclassify existing client")
+                (destroy popup)
+                (check-full-tile browser)
+                ;; Discord's main window uses the same class but only minima.
+                (let ((main (spawn :hints (xlib:make-wm-size-hints :min-width 800 :min-height 500))))
+                  (check (eq :tile (kind main)) "resizable Discord main window remains tiled")
+                  (check (< (xlib:drawable-width browser) 1000) "main window participates in master/stack")
+                  (destroy main))
+                (check-full-tile browser)
+                ;; A fixed width alone is not a fixed-size client.
+                (let ((one-axis (spawn :hints (xlib:make-wm-size-hints :min-width 300 :max-width 300))))
+                  (check (eq :tile (kind one-axis)) "one fixed axis stays tiled")
+                  (destroy one-axis))
+                (setf (lime.x11::x11-backend-configuration backend)
+                      (lime.x11:make-lime-configuration :new-client-focus-p nil))
+                (let ((quiet (spawn :hints fixed)))
+                  (check (eq :float (kind quiet)) "no-focus configuration still floats fixed window")
+                  (check (= (xlib:window-id browser) (xlib:window-id (xlib:input-focus clients)))
+                         "configured no-focus-on-new-client respected")
+                  (destroy quiet))
+                (setf (lime.x11::x11-backend-configuration backend)
+                      (lime.x11:make-lime-configuration
+                       :rules (list (lime.x11:make-window-rule :resource-class "discord" :float-p nil))))
+                (let ((forced (spawn :hints fixed))
+                      (splash (spawn :type :_NET_WM_WINDOW_TYPE_SPLASH)))
+                  (check (eq :tile (kind forced)) "explicit tiling rule overrides fixed-size default")
+                  (check (eq :float (kind splash)) "EWMH splash policy still wins over ordinary rules")
+                  (lime.x11:backend-select-head backend "right")
+                  (let ((transient (spawn :hints fixed :parent browser)))
+                    (check (eq :float (kind transient)) "transient parent policy still wins")
+                    (check (equal "left" (lime.x11::ewmh-active-head-id-for-client backend (id transient)))
+                           "transient follows parent onto left Head")
+                    (destroy transient))
+                  (destroy forced) (destroy splash))
+                (check-full-tile browser)
+                (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors")
+                (check (lime.core:validate-world (world)) "final world and leases valid")
+                (format t "~&Fixed-size 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* "~&Fixed-size smoke failed: ~A~%" condition)
+   (uiop:quit 1)))

test/x11-floating-smoke.lisp

@@ -0,0 +1,238 @@
+;;;; 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)))

test/x11-font-smoke.lisp

@@ -0,0 +1,163 @@
+;;;; Opt-in isolated-X font/overlay regression, including live reload/rollback.
+;;;; Requires Xvfb, Pango/Cairo, and fonts covering Japanese and color emoji.
+;;;; Optional: bind CL-USER::*FONT-SMOKE-IMAGE-DIRECTORY* before loading to save
+;;;; bar.png and palette.png for inspection. Never uses the current DISPLAY.
+;;;; *FONT-SMOKE-FONT-OPTIONS* optionally supplies MAKE-UI-FONT-STYLE keywords.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/x11")
+(defvar *font-smoke-image-directory* nil)
+(defvar *font-smoke-font-options* nil)
+
+(dolist (depth '(24 16))
+  (let ((server (uiop:launch-program
+                 (list "Xvfb" "-displayfd" "1" "-screen" "0"
+                       (format nil "1000x622x~D" depth) "-nolisten" "tcp")
+                 :output :stream :error-output :interactive))
+        (backend nil) (checks 0))
+    (unwind-protect
+         (let* ((number (parse-integer (read-line (uiop:process-info-output server))))
+                (configuration (lime.x11:make-lime-configuration
+                                :default-keybindings-p nil
+                                :bar-style (lime.x11:make-head-bar-style
+                                            :foreground "#dbc9a6" :focused-foreground "#dbc9a6"
+                                            :accent-color "#ffb054" :menu-label-color "#dbc9a6"
+                                            :logo-color "#768565")
+                                :font (apply #'lime.x11:make-ui-font-style *font-smoke-font-options*)
+                                :bar-height 24 :bar-height-supplied-p t)))
+           (setf backend (lime.x11:start-lime
+                          :display-name (format nil ":~D" number) :head-discovery :none))
+           (lime.x11:apply-lime-configuration backend configuration)
+           (let* ((display (lime.x11::x11-backend-display backend))
+                  (head (first (lime.x11:backend-head-ids backend)))
+                  (bar (gethash head (lime.x11::x11-backend-head-bars backend)))
+                  (client (xlib:create-window :parent (lime.x11::x11-backend-root backend)
+                                              :x 0 :y 0 :width 100 :height 100))
+                  (labels '("café — 日本語 🎮" "👩‍💻 Coding and debugging"
+                            "مرحبا بالعالم" "é — combining accents"))
+                  (session (lime.ui:make-ui-session
+                            (loop for label in labels for id from 0 collect
+                                  (lime.ui:make-ui-candidate :id id :label label :detail "Unicode sample")))))
+             (labels ((check (truth label)
+                        (assert truth () "Font smoke (~D-bit): ~A" depth label)
+                        (incf checks))
+                      (check-frame (canvas window)
+                        (xlib:display-finish-output display)
+                        (check (equalp (lime.x11::ui-canvas-pixels canvas)
+                                       (xlib:image-z-pixarray
+                                        (xlib:get-image window :x 0 :y 0
+                                                        :width (lime.x11::ui-canvas-width canvas)
+                                                        :height (lime.x11::ui-canvas-height canvas)
+                                                        :format :z-pixmap)))
+                               "painted frame survives the X11 pixel upload"))
+                      (snapshot (canvas name)
+                        (when (and (= depth 24) *font-smoke-image-directory*)
+                          (check (zerop (lime.x11::%cairo-write-png
+                                         (lime.x11::ui-canvas-surface canvas)
+                                         (namestring (merge-pathnames name *font-smoke-image-directory*))))
+                                 "PNG snapshot"))))
+               (xlib:change-property client :_NET_WM_NAME
+                                     (babel:string-to-octets (first labels) :encoding :utf-8)
+                                     :UTF8_STRING 8)
+               (lime.x11:manage-window backend client)
+               (lime.x11:backend-set-head-bar-status-providers
+                backend (list (lambda (&rest ignored)
+                                (declare (ignore ignored))
+                                (list (lime.x11:format-music-status '(:state :playing :title "スパイダー")
+                                                                   :playing-icon "▶" :icon-foreground "#76929f")
+                                      (lime.x11:format-volume-status '(:volume 25) :icon "♪"
+                                                                    :icon-foreground "#76929f")))))
+               (check-frame (lime.x11::x11-head-bar-canvas bar) (lime.x11::x11-head-bar-window bar))
+               (let ((pixels (lime.x11::ui-canvas-pixels (lime.x11::x11-head-bar-canvas bar))))
+                 (check (loop for y below 24 always
+                              (loop for x below 10 always
+                                    (= (aref pixels y x) (aref pixels 0 0)
+                                       (aref pixels y (- 999 x)))))
+                        "both outer text margins remain clear"))
+               ;; Inspect native RGB pixels: the logo is green, not the cream
+               ;; used by neighboring labels (before depth-specific upload).
+               (let* ((canvas (lime.x11::x11-head-bar-canvas bar))
+                      (data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas)))
+                      (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas)))
+                      (right (lime.x11::x11-head-bar-hit-region-right
+                              (first (lime.x11::x11-head-bar-hit-regions bar)))))
+                 (check (loop for y below 24 thereis
+                              (loop for x from 10 below right
+                                    for pixel = (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4)))
+                                    thereis (> (ldb (byte 8 8) pixel)
+                                               (max (ldb (byte 8 16) pixel) (ldb (byte 8 0) pixel)))))
+                        "Lime logo uses its independent green foreground"))
+               (snapshot (lime.x11::x11-head-bar-canvas bar) "bar.png")
+               (lime.x11::%open-ui-session backend session)
+               (let* ((overlay (lime.x11::x11-backend-ui-overlay backend))
+                      (old-bar-font (lime.x11::x11-head-bar-font bar))
+                      (old-font (lime.x11::x11-ui-overlay-font overlay))
+                      (old-canvas (lime.x11::x11-ui-overlay-canvas overlay))
+                      (old-height (lime.x11::x11-ui-overlay-height overlay))
+                      (large (lime.x11::copy-lime-configuration configuration)))
+                 (dolist (text labels)
+                   (check (zerop (lime.x11::text-metrics-unknown-glyphs
+                                 (lime.x11::%text-metrics old-font text)))
+                          (format nil "installed fonts cover ~S" text)))
+                 (check-frame old-canvas (lime.x11::x11-ui-overlay-window overlay))
+                 (snapshot old-canvas "palette.png")
+                 (lime.x11::%render-command-palette backend)
+                 (check (eq old-canvas (lime.x11::x11-ui-overlay-canvas overlay)) "reuse same-size canvas")
+                 (check (eq old-font (lime.x11::x11-ui-overlay-font overlay)) "reuse unchanged font")
+                 (setf (lime.x11:lime-configuration-font large)
+                       (lime.x11:make-ui-font-style :family "sans-serif, Noto Color Emoji" :size 22 :weight :bold)
+                       (lime.x11:lime-configuration-bar-height large) 36)
+                 (setf (lime.x11:lime-configuration-bar-style large)
+                       (lime.x11:make-head-bar-style :padding-x 16))
+                 (lime.x11:apply-lime-configuration backend large)
+                 (check (= (+ 16 (lime.x11::%text-width (lime.x11::x11-head-bar-font bar) "Lime"))
+                           (lime.x11::x11-head-bar-hit-region-right
+                            (first (lime.x11::x11-head-bar-hit-regions bar))))
+                        "padding reload also updates click geometry")
+                 (check (eq session (lime.x11::x11-backend-ui-session backend)) "reload preserves open session")
+                 (check (eq overlay (lime.x11::x11-backend-ui-overlay backend)) "reload preserves overlay window")
+                 (check (> (lime.x11::x11-ui-overlay-height overlay) old-height) "font increases measured row height")
+                 (check (= 36 (xlib:drawable-y (lime.x11::x11-ui-overlay-window overlay))) "overlay follows new bar height")
+                 (check (null (lime.x11::ui-text-font-layout old-font)) "reload frees old palette font")
+                 (check (null (lime.x11::ui-text-font-layout old-bar-font)) "reload frees old bar font")
+                 (check (null (lime.x11::ui-canvas-surface old-canvas)) "resize frees old canvas")
+                 (check (= 22 (lime.x11:ui-font-style-size
+                               (lime.x11::ui-text-font-style (lime.x11::x11-ui-overlay-font overlay))))
+                        "palette uses configured pixel size")
+                 (check-frame (lime.x11::x11-ui-overlay-canvas overlay) (lime.x11::x11-ui-overlay-window overlay))
+                 (let ((bad (lime.x11::copy-lime-configuration large))
+                       (failed nil) (failed-font nil))
+                   (setf (lime.x11:lime-configuration-font bad) (lime.x11:make-ui-font-style :size 10)
+                         (lime.x11:lime-configuration-startup-hooks bad)
+                         (list (lambda (ignored)
+                                 (declare (ignore ignored))
+                                 (setf failed-font (lime.x11::x11-ui-overlay-font overlay))
+                                 (error "Deliberate font rollback"))))
+                   (handler-case (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t)
+                     (error () (setf failed t)))
+                   (check (and failed failed-font) "installation reaches deliberate rollback")
+                   (check (eq large (lime.x11:x11-backend-configuration backend)) "previous config restored")
+                   (check (null (lime.x11::ui-text-font-layout failed-font)) "rollback frees failed font")
+                   (check (= 22 (lime.x11:ui-font-style-size
+                                 (lime.x11::ui-text-font-style (lime.x11::x11-head-bar-font bar))))
+                          "rollback restores bar font")
+                   (check (= 22 (lime.x11:ui-font-style-size
+                                 (lime.x11::ui-text-font-style (lime.x11::x11-ui-overlay-font overlay))))
+                          "rollback restores overlay font")
+                   (check-frame (lime.x11::x11-ui-overlay-canvas overlay) (lime.x11::x11-ui-overlay-window overlay)))
+                 ;; Closing and reopening frees all transient native resources.
+                 (lime.x11:backend-close-command-palette backend)
+                 (check (null (lime.x11::ui-text-font-layout (lime.x11::x11-ui-overlay-font overlay)))
+                        "close frees palette layout")
+                 (check (null (lime.x11::ui-canvas-surface (lime.x11::x11-ui-overlay-canvas overlay)))
+                        "close frees palette canvas")
+                 (lime.x11::%open-ui-session backend session)
+                 (check (not (eq overlay (lime.x11::x11-backend-ui-overlay backend))) "reopen builds a new overlay"))
+               (lime.x11:stop-backend backend)
+               (setf backend nil)
+               (check (null (lime.x11::ui-text-font-layout (lime.x11::x11-head-bar-font bar))) "shutdown frees bar font")
+               (check (null (lime.x11::ui-canvas-surface (lime.x11::x11-head-bar-canvas bar))) "shutdown frees bar canvas")
+               (format t "~&Live X11 fonts (~D-bit): ~D checks passed.~%" depth checks))))
+      (when backend (lime.x11:stop-backend backend))
+      (uiop:terminate-process server)
+      (uiop:wait-process server))))

test/x11-head-send-smoke.lisp

@@ -0,0 +1,175 @@
+;;;; Physical key grabs and clickable confirmation on our own Xvfb only.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/x11")
+
+(lime.config:defconfiguration head-send-smoke-config
+  (:command send-window :label "Send window"
+   :action (lambda (backend) (lime.x11:backend-send-focused-client-relatively backend :next)))
+  (:bind #\e send-window :modifiers '(:mod-4 :shift)))
+
+(let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x622x24" "-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))
+              (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 600 :height 622)
+                           (lime.x11:make-x11-head :head-id "right" :x 600 :y 0 :width 600 :height 622))))
+         (setf backend (lime.x11:start-lime :display-name display-name :heads heads :install-default-keybindings-p nil)
+               clients (xlib:open-default-display display-name))
+         (lime.x11:apply-lime-configuration backend head-send-smoke-config)
+         (labels ((check (truth label) (assert truth () "Head send: ~A" label) (incf checks))
+                  (world () (lime.x11:x11-backend-world backend))
+                  (current (head) (lime.core:current-presentation (world) head))
+                  (session () (lime.x11::x11-backend-ui-session backend))
+                  (pump ()
+                    (xlib:display-finish-output clients)
+                    (let ((turns 0) (display (lime.x11::x11-backend-display backend)))
+                      (lime.x11:run-event-loop backend :timeout 0.005
+                       :before-event (lambda (b)
+                                       (assert (< (incf turns) 500) () "Event queue did not settle.")
+                                       (xlib:display-finish-output display)
+                                       (unless (xlib:event-listen display)
+                                         (setf (lime.x11::x11-backend-running-p b) nil))))))
+                  (tap (keysym &optional modified-p)
+                    (let* ((display (lime.x11::x11-backend-display backend))
+                           (super (first (nth-value 6 (xlib:modifier-mapping display))))
+                           (shift (first (nth-value 0 (xlib:modifier-mapping display))))
+                           (key (xlib:keysym->keycodes display keysym)))
+                      (assert key)
+                      (when modified-p
+                        (xlib/xtest:fake-key-event clients super t)
+                        (xlib/xtest:fake-key-event clients shift t))
+                      (xlib/xtest:fake-key-event clients key t)
+                      (xlib/xtest:fake-key-event clients key nil)
+                      (when modified-p
+                        (xlib/xtest:fake-key-event clients shift nil)
+                        (xlib/xtest:fake-key-event clients super nil))
+                      (pump)))
+                  (spawn ()
+                    (let ((window (xlib:create-window :parent (xlib:screen-root (xlib:display-default-screen clients))
+                                                     :x 30 :y 30 :width 120 :height 120)))
+                      (xlib:map-window window) (pump)
+                      (values window (lime.x11::%backend-client-id backend window))))
+                  (lease-head (id) (lime.x11::ewmh-active-head-id-for-client backend id))
+                  (choose (id)
+                    (let ((candidate (find id (lime.ui:ui-session-candidates (session))
+                                           :key #'lime.ui:ui-candidate-id :test #'equal)))
+                      (check candidate "choice present")
+                      (lime.x11::%perform-ui-action backend (list :candidate candidate))
+                      (pump))))
+           (lime.x11:backend-start-activity backend "work" "Work")
+           (lime.x11:backend-start-activity backend "chill" "Chill" :head-id "right")
+           (lime.x11:backend-select-head backend "left")
+           (multiple-value-bind (a aid) (spawn)
+             (multiple-value-bind (b bid) (spawn)
+               (lime.x11:backend-save-view backend "code" "Code")
+               (lime.x11:backend-select-head backend "right")
+               (multiple-value-bind (c cid) (spawn)
+                 (lime.x11:backend-use-monocle-layout backend)
+                 (lime.x11:backend-save-view backend "chat" "Chat")
+                 (lime.x11:backend-select-head backend "left")
+                 (pump)
+                 (let ((before (lime.persistence:snapshot-world (world))))
+                   (tap (char-code #\e) t)
+                   (check (session) "Super-Shift-e opens confirmation")
+                   (check (equal "left" (lime.x11::x11-ui-overlay-head-id (lime.x11::x11-backend-ui-overlay backend)))
+                          "confirmation is on source Head")
+                   (check (< (lime.x11::x11-ui-overlay-height (lime.x11::x11-backend-ui-overlay backend)) 220)
+                          "two-choice dropdown stays compact")
+                   (check (eq :cancel (lime.ui:ui-candidate-id (lime.ui:ui-session-selected-candidate (session))))
+                          "default is Cancel")
+                   (check (search "saved views" (lime.ui:ui-candidate-detail
+                                                 (lime.ui:ui-session-selected-candidate (session)))) "warning visible on default choice")
+                   (check (equalp before (lime.persistence:snapshot-world (world))) "opening is read-only")
+                   (tap #xFF0D)
+                   (check (not (session)) "Enter cancels by default")
+                   (check (equalp before (lime.persistence:snapshot-world (world))) "cancel leaves desk untouched")
+                   (check (equal "left" (lime.x11:x11-backend-focused-head-id backend)) "cancel keeps source Head selected")
+                   (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "cancel preserves real focus"))
+                 ;; Configured command search returns a transition into the
+                 ;; existing overlay, rather than opening then closing itself.
+                 (lime.x11:backend-open-command-palette backend)
+                 (tap (char-code #\Space))
+                 (choose '(:configured-command send-window))
+                 (check (session) "configured search action keeps confirmation open")
+                 (tap #xFF1B)
+                 ;; The which-key path shares the same action and click regions.
+                 (lime.x11:backend-open-command-palette backend)
+                 (tap (char-code #\h)) (tap (char-code #\s))
+                 (check (session) "h s opens confirmation")
+                 (let* ((overlay (lime.x11::x11-backend-ui-overlay backend))
+                        (candidate (second (lime.ui:ui-session-candidates (session))))
+                        (region (find (list :candidate candidate) (lime.x11::x11-ui-overlay-hit-regions overlay)
+                                      :key #'lime.x11::ui-hit-region-action :test #'equal)))
+                   (check region "Move is clickable")
+                   (xlib/xtest:fake-motion-event
+                    clients (+ (xlib:drawable-x (lime.x11::x11-ui-overlay-window overlay))
+                               (lime.x11::ui-hit-region-x region) 10)
+                    (+ (xlib:drawable-y (lime.x11::x11-ui-overlay-window overlay))
+                       (lime.x11::ui-hit-region-y region) 5))
+                   (pump)
+                   (xlib/xtest:fake-button-event clients 1 t)
+                   (xlib/xtest:fake-button-event clients 1 nil)
+                   (pump))
+                 (check (not (session)) "click confirms and closes dropdown")
+                 (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) bid))) "home changed")
+                 (check (equal "right" (lease-head bid)) "one destination lease")
+                 (check (equal "work" (lime.core:presentation-activity-id (current "left"))) "source Activity unchanged")
+                 (check (equal "chill" (lime.core:presentation-activity-id (current "right"))) "destination Activity unchanged")
+                 (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "keyboard Head follows confirmed move")
+                 (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "sent client gets actual X focus")
+                 (check (equal aid (lime.core:presentation-focus-client-id (current "left"))) "source remembers survivor")
+                 (check (eq :viewable (xlib:window-map-state b)) "sent window visible in monocle")
+                 (check (eq :unmapped (xlib:window-map-state c)) "previous monocle client stays in cycle but is not shown")
+                 (check (>= (xlib:drawable-x b) 600) "real window moved right")
+                 (check (equal (list aid) (mapcar #'lime.core:placement-client-id
+                                                  (lime.core:view-placements (lime.core:find-view (world) "code")))) "old checkpoint pruned")
+                 (check (equal (list cid) (mapcar #'lime.core:placement-client-id
+                                                  (lime.core:view-placements (lime.core:find-view (world) "chat")))) "destination checkpoint not overwritten")
+                 ;; Same Activity: immediate transfer, no confirmation.
+                 (lime.x11:backend-extend-activity-to-head backend "chill" "left")
+                 (lime.x11:backend-select-head backend "right")
+                 (tap (char-code #\e) t)
+                 (check (not (session)) "same Activity sends immediately")
+                 (check (equal "left" (lease-head bid)) "same-Activity transfer moves lease")
+                 (check (equal "left" (lime.x11:x11-backend-focused-head-id backend)) "same-Activity focus follows")
+                 (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "same-Activity real focus follows")
+                 ;; Repeat the binding directly: no separate Head focus command.
+                 (tap (char-code #\e) t)
+                 (check (equal "right" (lease-head bid)) "repeated shortcut sends same client back")
+                 (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "repeated shortcut follows back")
+                 (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "repeated shortcut keeps real focus")
+                 (tap (char-code #\e) t)
+                 (check (equal "left" (lease-head bid)) "third shortcut still targets same client")
+                 ;; Shared float crosses back to Work without rehoming.
+                 (lime.x11:backend-switch-to-activity backend "work" :head-id "right")
+                 (lime.x11:backend-select-head backend "left")
+                 (lime.x11:backend-set-client-shared backend bid t)
+                 (lime.x11:backend-toggle-focused-client-floating backend)
+                 (let ((data (copy-tree (lime.core:placement-data
+                                         (find bid (lime.core:presentation-placements (current "left"))
+                                               :key #'lime.core:placement-client-id :test #'equal)))))
+                   (tap (char-code #\e) t)
+                   (check (not (session)) "shared cross-Activity send is immediate")
+                   (check (equal "right" (lease-head bid)) "shared lease moved")
+                   (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "shared floating move follows")
+                   (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "shared float gets real focus")
+                   (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) bid))) "shared home unchanged")
+                   (check (equal data (lime.core:placement-data
+                                      (find bid (lime.core:presentation-placements (current "right"))
+                                            :key #'lime.core:placement-client-id :test #'equal)))
+                          "normalized floating geometry retained"))
+                 (multiple-value-bind (d did) (spawn)
+                   (check (equal "right" (lease-head did)) "new window routes to followed Head")
+                   (check (equal "work" (lime.core:client-activity-id (lime.core:find-client (world) did)))
+                          "new window belongs to followed Activity")
+                   (check (= (xlib:window-id d) (xlib:window-id (xlib:input-focus clients))) "new window focuses on destination"))
+                 (check (lime.core:validate-world (world)) "world valid after all moves")
+                 (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors")
+                 (format t "~&Live X11 Head-send smoke: ~D checks passed.~%" checks))))))
+    (when backend (lime.x11:stop-backend backend))
+    (when clients (xlib:close-display clients))
+    (uiop:terminate-process server)
+    (uiop:wait-process server)))

test/x11-launcher-smoke.lisp

@@ -0,0 +1,124 @@
+;;;; Burst typing and grab cleanup on an owned Xvfb, never the live 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" "1000x622x24" "-nolisten" "tcp")
+                                  :output :stream :error-output :interactive))
+      (backend nil) (clients nil) (checks 0)
+      (original-launch (symbol-function 'lime.x11:backend-launch-program))
+      (original-scan (symbol-function 'lime.x11::%scan-path-program-names))
+      (original-overlay (symbol-function 'lime.x11::%make-ui-overlay))
+      (lime.x11::*path-program-cache* nil))
+  (unwind-protect
+       (let* ((number (parse-integer (read-line (uiop:process-info-output server))))
+              (display-name (format nil ":~D" number))
+              (launched nil) (queries nil) (scans 0) (typed nil) (ordinary 0))
+         (setf backend (lime.x11:start-lime :display-name display-name :head-discovery :none
+                                          :install-default-keybindings-p nil)
+               clients (xlib:open-default-display display-name))
+         (let* ((display (lime.x11::x11-backend-display backend))
+                (super (first (nth-value 6 (xlib:modifier-mapping display))))
+                (window (xlib:create-window :parent (xlib:screen-root (xlib:display-default-screen clients))
+                                            :x 20 :y 20 :width 100 :height 100 :event-mask '(:key-press))))
+           (labels ((check (truth label) (assert truth () "Launcher: ~A" label) (incf checks))
+                    (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) 500) () "Event queue did not settle.")
+                                         (xlib:display-finish-output display)
+                                         (unless (xlib:event-listen display)
+                                           (setf (lime.x11::x11-backend-running-p b) nil))))))
+                    (tap (keysym)
+                      (let ((code (xlib:keysym->keycodes display keysym)))
+                        (assert code)
+                        (xlib/xtest:fake-key-event clients code t)
+                        (xlib/xtest:fake-key-event clients code nil)))
+                    (shortcut (char)
+                      (xlib/xtest:fake-key-event clients super t)
+                      (tap (char-code char))
+                      (xlib/xtest:fake-key-event clients super nil))
+                    (text-burst (text)
+                      (loop for char across text do (tap (char-code char))))
+                    (read-client-keys ()
+                      (xlib:display-finish-output clients)
+                      (loop while (xlib:event-listen clients)
+                            do (xlib:event-case (clients :timeout 0)
+                                 (:key-press (code state)
+                                   (let ((char (xlib:keysym->character clients (xlib:keycode->keysym clients code 0) state)))
+                                     (when (and (characterp char) (graphic-char-p char)) (push char typed))) t)
+                                 (otherwise () t)))))
+             (xlib:map-window window) (pump)
+             (check (= (xlib:window-id window) (xlib:window-id (xlib:input-focus clients))) "application has real focus")
+             ;; Measure actual cold/warm opening with the real PATH catalog.
+             (dotimes (i 3)
+               (let ((start (get-internal-real-time)))
+                 (lime.x11:backend-open-run-prompt backend)
+                 (xlib:display-finish-output display)
+                 (format t "~&Launcher ~A open: ~,2F ms~%" (if (zerop i) "cold" "warm")
+                         (* 1000.0 (/ (- (get-internal-real-time) start) internal-time-units-per-second))))
+               (lime.x11:backend-close-command-palette backend) (pump))
+             ;; Stub only process creation and catalog discovery, not X grabs,
+             ;; filtering, menu creation, event dispatch, or key delivery.
+             (setf lime.x11::*path-program-cache* nil
+                   (symbol-function 'lime.x11::%scan-path-program-names)
+                   (lambda () (incf scans) (sleep 0.05) '("emoji-menu" "st"))
+                   (symbol-function 'lime.x11:backend-launch-program)
+                   (lambda (b argv)
+                     (push argv launched)
+                     (push (lime.ui:ui-session-query (lime.x11::x11-backend-ui-session b)) queries)))
+             (lime.x11:bind-key backend #\p '(:mod-4) #'lime.x11:backend-open-run-prompt)
+             (xlib:display-finish-output display)
+             (dotimes (i 3)
+               ;; No event pumping between the trigger and the following keys.
+               (shortcut #\p) (text-burst "emo") (tap #xFF0D)
+               (pump) (read-client-keys)
+               (check (not (lime.x11:backend-command-palette-open-p backend)) "burst Enter launches and closes")
+               (check (= (1+ i) (length launched)) "exactly one program launched per burst")
+               (check (equal '("emoji-menu") (first launched)) "correct executable selected")
+               (check (equal "emo" (first queries)) "first letter and complete query retained")
+               (check (null typed) "no characters leaked into old application"))
+             (check (= 1 scans) "subsequent opens reuse executable catalog")
+             ;; Prefix menus use the same safe handoff.
+             (lime.x11:bind-key backend #\y '(:mod-4) #'lime.x11:backend-open-command-palette)
+             (xlib:display-finish-output display)
+             (shortcut #\y) (tap (char-code #\w)) (pump) (read-client-keys)
+             (check (equal "Lime  ›  w Windows" (lime.x11::%ui-menu-heading (lime.x11::x11-backend-ui-session backend)))
+                    "fast which-key prefix retained")
+             (check (null typed) "prefix did not reach application")
+             (tap #xFF1B) (pump)
+             ;; Ordinary commands and failures must not leave input frozen.
+             (lime.x11:bind-key backend #\n '(:mod-4) (lambda (b) (declare (ignore b)) (incf ordinary)))
+             (lime.x11:bind-key backend #\f '(:mod-4) (lambda (b) (declare (ignore b)) (error "expected test failure")))
+             (xlib:display-finish-output display)
+             (shortcut #\n) (text-burst "a") (pump) (read-client-keys)
+             (check (= 1 ordinary) "ordinary shortcut ran")
+             (check (equal '(#\a) typed) "ordinary command thawed keyboard")
+             (setf typed nil)
+             (shortcut #\f) (text-burst "b") (pump) (read-client-keys)
+             (check (lime.x11:backend-last-command-error backend) "handler error contained")
+             (check (equal '(#\b) typed) "failed command thawed keyboard")
+             (setf typed nil (symbol-function 'lime.x11::%make-ui-overlay)
+                   (lambda (&rest args) (declare (ignore args)) (error "expected overlay failure")))
+             (shortcut #\p) (text-burst "c") (pump) (read-client-keys)
+             (check (not (lime.x11:backend-command-palette-open-p backend)) "failed opening leaves no session")
+             (check (equal '(#\c) typed) "failed opening thawed keyboard")
+             (setf (symbol-function 'lime.x11::%make-ui-overlay) original-overlay)
+             ;; Release/ungrab remains correct after all success/error paths.
+             (check (eq :success (xlib:grab-keyboard window)) "another client can grab after cleanup")
+             (xlib:ungrab-keyboard clients) (xlib:display-finish-output clients)
+             (format t "~&Live X11 launcher smoke: ~D checks passed.~%" checks))))
+    (setf (symbol-function 'lime.x11:backend-launch-program) original-launch
+          (symbol-function 'lime.x11::%scan-path-program-names) original-scan
+          (symbol-function 'lime.x11::%make-ui-overlay) original-overlay)
+    (when backend (lime.x11:stop-backend backend))
+    (when clients (xlib:close-display clients))
+    (uiop:terminate-process server)
+    (uiop:wait-process server)))
+  (error (condition)
+    (format *error-output* "~&Launcher smoke failed: ~A~%" condition)
+    (uiop:quit 1)))

test/x11-membership-smoke.lisp

@@ -0,0 +1,196 @@
+;;;; Owned Xvfb only: real windows, menu actions, leases, and session restore.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/x11")
+
+(handler-case
+ (let* ((directory (uiop:ensure-directory-pathname
+                    (string-trim '(#\Newline)
+                                 (uiop:run-program '("mktemp" "-d" "/tmp/lime-membership-XXXXXX") :output :string))))
+        (path (merge-pathnames "session.sexp" directory))
+        (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))
+               (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))))
+          (setf clients (xlib:open-default-display display-name))
+          (let* ((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 () "Membership: ~A" label) (incf checks))
+                     (world () (lime.x11:x11-backend-world backend))
+                     (current (head) (lime.core:current-presentation (world) head))
+                     (session () (lime.x11::x11-backend-ui-session backend))
+                     (start () (setf backend (lime.x11:start-lime :display-name display-name :heads heads
+                                                                 :install-default-keybindings-p nil :session-file path)))
+                     (pump ()
+                       (xlib:display-finish-output clients)
+                       (let ((turns 0) (display (lime.x11::x11-backend-display backend)))
+                         (lime.x11:run-event-loop
+                          backend :timeout 0.005
+                          :before-event (lambda (b)
+                                          (assert (< (incf turns) 400) () "Membership event queue did not settle.")
+                                          (xlib:display-finish-output display)
+                                          (unless (xlib:event-listen display)
+                                            (setf (lime.x11::x11-backend-running-p b) nil))))))
+                     (key (key) (lime.x11::%perform-ui-action backend (list :key key)) (pump))
+                     (choose (id)
+                       (let ((candidate (find id (lime.ui:ui-session-candidates (session))
+                                              :key #'lime.ui:ui-candidate-id :test #'equal)))
+                         (check candidate (format nil "candidate ~S" id))
+                         (lime.x11::%perform-ui-action backend (list :candidate candidate)))
+                       (pump))
+                     (adopt (window)
+                       (xlib:display-finish-output clients)
+                       (prog1 (lime.x11:manage-window backend
+                                                      (xlib::lookup-window (lime.x11::x11-backend-display backend)
+                                                                           (xlib:window-id window)))
+                         (pump))))
+              (start)
+              (lime.x11:backend-start-activity backend "work" "Work")
+              (lime.x11:backend-start-activity backend "chill" "Chill" :head-id "right")
+              (lime.x11:backend-select-head backend "left")
+              (setf aid (adopt a) bid (adopt b))
+              (lime.x11:backend-save-view backend "code" "Code")
+              (check (eq :viewable (xlib:window-map-state a)) "A initially shown")
+              (check (eq :viewable (xlib:window-map-state b)) "B initially shown")
+              (lime.x11:backend-open-command-palette backend)
+              (key #\w) (key #\m)
+              (check (eq :search (lime.ui:ui-session-mode (session))) "w m opens destination picker")
+              (choose (list :move-client-to-activity bid "chill"))
+              (check (not (session)) "move closes menu")
+              (check (eq :viewable (xlib:window-map-state b)) "portable destination receives window without closing it")
+              (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend))) "unmap did not withdraw client")
+              (check (equal "work" (lime.core:presentation-activity-id (current "left"))) "move stays in source Activity")
+              (check (equal (list bid) (lime.core:presentation-client-ids (current "right"))) "window joins actual portable arrangement")
+              (check (equal aid (lime.core:presentation-focus-client-id (current "left"))) "source focuses surviving client")
+              (check (equal (list aid) (mapcar #'lime.core:placement-client-id
+                                              (lime.core:view-placements (lime.core:find-view (world) "code")))) "checkpoint pruned")
+              (lime.x11:backend-activate-activity backend "chill" :head-id "left")
+              (pump)
+              (check (eq :viewable (xlib:window-map-state b)) "destination draft shows moved window")
+              (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "moved window receives real focus")
+              (lime.x11:backend-activate-activity backend "work" :head-id "left")
+              (pump)
+              (lime.x11:backend-open-command-palette backend)
+              (key #\w) (key #\s)
+              (check (not (session)) "share action closes menu")
+              (check (lime.core:client-shared-p (lime.core:find-client (world) aid)) "shared flag enabled")
+              (check (< (xlib:drawable-x a) 600) "sharing alone does not move window")
+              (lime.x11:backend-select-head backend "right")
+              (lime.x11:backend-open-hidden-client-picker backend)
+              (let ((before (lime.persistence:snapshot-world (world))))
+                (choose (list :show-hidden-client aid))
+                (check (equalp before (lime.persistence:snapshot-world (world))) "collision prompt changes no model state"))
+              (choose (list :take-hidden-client aid))
+              (check (not (session)) "explicit take closes menu")
+              (check (>= (xlib:drawable-x a) 600) "same real window now on right Head")
+              (check (= (xlib:window-id a) (xlib:window-id (xlib:input-focus clients))) "borrowed window focused")
+              (check (equal "work" (lime.core:client-activity-id (lime.core:find-client (world) aid))) "home unchanged")
+              (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend aid)) "one lease on right")
+              (check (lime.core:validate-world (world)) "borrowed desk valid")
+              (lime.x11:backend-hide-client backend bid :head-id "right")
+              (lime.x11:backend-save-view backend "music" "Music")
+              ;; Persist shared guest plus moved private client, then reconnect
+              ;; to both existing XIDs, including the currently hidden one.
+              (lime.x11:backend-save-session backend)
+              (lime.x11:stop-backend backend)
+              (setf backend nil)
+              (start) (pump)
+              (check (= 2 (getf (getf (lime.x11:backend-session-status backend) :restore) :matched)) "restart matches both clients")
+              (check (lime.core:client-shared-p (lime.core:find-client (world) aid)) "sharing restored")
+              (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend aid)) "borrowed lease restored")
+              (check (eq :unmapped (xlib:window-map-state b)) "moved private window remains parked")
+              (check (>= (xlib:drawable-x a) 600) "borrowed real placement restored")
+              ;; Left still has an unavailable slot, not an omitted placement;
+              ;; the same Super-i workflow must be able to take it back.
+              (lime.x11:backend-select-head backend "left")
+              (lime.x11:backend-open-hidden-client-picker backend)
+              (choose (list :show-hidden-client aid))
+              (choose (list :take-hidden-client aid))
+              (check (< (xlib:drawable-x a) 600) "shared slot summoned back")
+              (lime.x11:backend-show-client-taking backend aid :head-id "right")
+              (pump)
+              (let ((before (lime.persistence:snapshot-world (world)))
+                    (lease (lime.core:lease-for-client (world) aid))
+                    (target (current "right"))
+                    (geometry (list (xlib:drawable-x a) (xlib:drawable-y a)
+                                    (xlib:drawable-width a) (xlib:drawable-height a))))
+                (lime.x11:backend-open-command-palette backend)
+                (key #\w) (key #\s)
+                (check (lime.core:client-shared-p (lime.core:find-client (world) aid)) "private action waits for confirmation")
+                (check (find "Make private to Chill" (lime.ui:ui-session-candidates (session))
+                             :key #'lime.ui:ui-candidate-label :test #'equal) "confirmation names current Activity")
+                (key :return)
+                (check (not (session)) "private confirmation defaults to Cancel")
+                (check (equalp before (lime.persistence:snapshot-world (world))) "Cancel leaves world untouched")
+                (lime.x11:backend-open-command-palette backend)
+                (key #\w) (key #\s)
+                (choose (list :make-client-private aid))
+                (check (eq :viewable (xlib:window-map-state a)) "private window stays mapped")
+                (check (equal geometry (list (xlib:drawable-x a) (xlib:drawable-y a)
+                                            (xlib:drawable-width a) (xlib:drawable-height a))) "geometry unchanged")
+                (check (= (xlib:window-id a) (xlib:window-id (xlib:input-focus clients))) "real focus unchanged")
+                (check (eq lease (lime.core:lease-for-client (world) aid)) "same lease object retained")
+                (check (eq target (current "right")) "same arrangement retained"))
+              (check (not (lime.core:client-shared-p (lime.core:find-client (world) aid))) "sharing revoked")
+              (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) aid))) "current Activity becomes home")
+              (check (null (lime.core:view-placements (lime.core:find-view (world) "code"))) "old home checkpoint cleaned")
+              (check (equal (list aid) (mapcar #'lime.core:placement-client-id
+                                              (lime.core:view-placements (lime.core:find-view (world) "music")))) "current Activity checkpoint retained")
+              (check (handler-case (progn (lime.x11:backend-show-client backend aid :head-id "left") nil)
+                       (lime.core:invalid-transition () t)) "old home cannot reclaim private client")
+              (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors")
+              (check (lime.core:validate-world (world)) "final world valid")
+              ;; Deletion uses a picker and explicit confirmation, never an
+              ;; application close. Exercise actual key/menu dispatch and X.
+              (lime.x11:backend-start-activity backend "old" "Old task" :head-id "left")
+              (lime.x11:backend-save-view backend "old/checkpoint" "Checkpoint" :head-id "left")
+              (lime.x11:backend-activate-activity backend "work" :head-id "left")
+              (pump)
+              (let ((snapshot (lime.persistence:snapshot-world (world))))
+                (lime.x11:backend-open-command-palette backend)
+                (key #\a) (key #\d)
+                (check (eq :search (lime.ui:ui-session-mode (session))) "a d opens deletion picker")
+                (choose '(:delete-activity "old"))
+                (check (equalp snapshot (lime.persistence:snapshot-world (world))) "deletion prompt does not mutate")
+                (key :return)
+                (check (not (session)) "Enter defaults to Cancel")
+                (check (equalp snapshot (lime.persistence:snapshot-world (world))) "cancel retains Activity and arrangements"))
+              (lime.x11:backend-open-command-palette backend)
+              (key #\a) (key #\d)
+              (choose '(:delete-activity "old"))
+              (choose '(:confirm-delete-activity "old"))
+              (check (not (session)) "confirmed deletion closes menu")
+              (check (not (find "old" (lime.core:list-activities (world)) :key #'lime.core:activity-id :test #'equal)) "Activity removed")
+              (check (equal "work" (lime.core:presentation-activity-id (current "left"))) "left Head unchanged")
+              (check (equal "chill" (lime.core:presentation-activity-id (current "right"))) "right Head unchanged")
+              (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend))) "all real windows retained")
+              (check (eq :viewable (xlib:window-map-state a)) "visible client stays visible")
+              (check (eq :unmapped (xlib:window-map-state b)) "hidden client stays hidden")
+              (lime.x11:backend-save-session backend)
+              (lime.x11:stop-backend backend)
+              (setf backend nil)
+              (start) (pump)
+              (check (not (find "old" (lime.core:list-activities (world)) :key #'lime.core:activity-id :test #'equal)) "deleted Activity stays deleted after restart")
+              (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) aid))) "new home survives restart")
+              (check (not (lime.core:client-shared-p (lime.core:find-client (world) aid))) "private flag survives restart")
+              (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend aid)) "private lease restored on right")
+              (check (and (eq :viewable (xlib:window-map-state a)) (>= (xlib:drawable-x a) 600)) "private window restored in place")
+              (check (null (lime.core:view-placements (lime.core:find-view (world) "code"))) "old checkpoint pruning persists")
+              (check (equal (list aid) (mapcar #'lime.core:placement-client-id
+                                              (lime.core:view-placements (lime.core:find-view (world) "music")))) "kept checkpoint persists")
+              (check (null (lime.x11::x11-backend-last-command-error backend)) "no deletion menu errors")
+              (check (lime.core:validate-world (world)) "post-deletion restored world valid")
+              (format t "~&Membership 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* "~&Membership smoke failed: ~A~%" condition)
+   (uiop:quit 1)))

test/x11-membership.lisp

@@ -0,0 +1,281 @@
+(in-package #:lime.x11.test)
+(in-suite lime-x11-suite)
+
+(defmacro with-membership-backend ((backend world) &body body)
+  `(let* ((,backend (make-head-bar-fixture)) (,world (x11-backend-world ,backend))
+          (original (symbol-function 'apply-active-presentation)))
+     (create-activity ,world "chill" "Chill")
+     (create-head ,world "other")
+     (setf (gethash "other" (lime.x11::x11-backend-heads ,backend))
+           (make-x11-head :head-id "other" :x 840 :y 30 :width 800 :height 600)
+           (lime.x11::x11-backend-head-ids ,backend) '("main" "other"))
+     (open-activity-draft ,world "other" "chill")
+     (unwind-protect
+          (progn
+            (setf (symbol-function 'apply-active-presentation) (lambda (b) b))
+            ,@body)
+       (setf (symbol-function 'apply-active-presentation) original))))
+
+(test cross-activity-head-send-needs-explicit-confirmation
+  (with-membership-backend (backend world)
+    (let* ((before (lime.persistence:snapshot-world world))
+           (source (current-presentation world "main"))
+           (target (current-presentation world "other"))
+           (result (lime.x11::%ui-request-client-send backend "other")))
+      (is (eq :replace (ui-result-kind result)))
+      (is (eq :cancel (ui-candidate-id (first (ui-result-candidates result)))))
+      (is (search "Development to Chill" (lime.ui:ui-result-message result)))
+      (is (search "saved views" (ui-candidate-detail (first (ui-result-candidates result)))))
+      (is (equalp before (lime.persistence:snapshot-world world)))
+      (is (eq :close (ui-result-kind (funcall (ui-candidate-action (first (ui-result-candidates result)))))))
+      (is (equalp before (lime.persistence:snapshot-world world)))
+      (is (equal "main" (x11-backend-focused-head-id backend)))
+      (is (eq :close (ui-result-kind (funcall (ui-candidate-action (second (ui-result-candidates result)))))))
+      (is (equal "chill" (client-activity-id (find-client world "editor"))))
+      (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "editor")))
+      (is (equal "other" (lime.x11:x11-backend-focused-head-id backend)))
+      (is (equal "chill" (lime.x11::x11-backend-activity-id backend)))
+      (is (eq source (current-presentation world "main")))
+      (is (eq target (current-presentation world "other")))
+      (is (equal "terminal" (presentation-focus-client-id source)))
+      (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "development/code")))))
+      (is (validate-world world))
+      (let ((snapshot (lime.persistence:snapshot-world world)))
+        (is (equalp snapshot (lime.persistence:snapshot-world (lime.persistence:restore-world snapshot))))))))
+
+(test head-send-confirmations-reject-stale-context-without-retargeting
+  (dolist (change '(:head :focus :target :hide :retire :shared :new-client))
+    (with-membership-backend (backend world)
+      (let* ((result (lime.x11::%ui-request-client-send backend "other"))
+             (action (ui-candidate-action (second (ui-result-candidates result)))))
+        (ecase change
+          (:head (setf (lime.x11:x11-backend-focused-head-id backend) "other"))
+          (:focus (focus-client-on-presentation world "terminal" (presentation-id (current-presentation world "main"))))
+          (:target (open-activity-draft world "other" "development"))
+          (:hide (backend-hide-client backend "editor"))
+          (:retire (retire-client world "editor"))
+          (:shared (set-client-shared world "editor" t))
+          (:new-client (create-client world "new" "chill")))
+        (let ((before (lime.persistence:snapshot-world world))
+              (head (x11-backend-focused-head-id backend)))
+          (is (eq :keep-open (ui-result-kind (funcall action))))
+          (is (equal head (x11-backend-focused-head-id backend)))
+          (is (equalp before (lime.persistence:snapshot-world world))))))))
+
+(test same-activity-and-shared-head-sends-stay-immediate-and-do-not-rehome
+  (dolist (shared-p '(nil t))
+    (with-membership-backend (backend world)
+      (if shared-p (set-client-shared world "editor" t)
+          (open-activity-draft world "other" "development"))
+      (set-presentation-layout-mode world (presentation-id (current-presentation world "other")) :monocle)
+      (setf (lime.x11::x11-backend-focus-root-override-p backend) t)
+      (is (eq :close (ui-result-kind (lime.x11::%ui-request-client-send backend "other"))))
+      (is (equal "development" (client-activity-id (find-client world "editor"))))
+      (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "editor")))
+      (is (equal "editor" (presentation-focus-client-id (current-presentation world "other"))))
+      (is (equal "other" (lime.x11:x11-backend-focused-head-id backend)))
+      (is (equal (if shared-p "chill" "development") (lime.x11::x11-backend-activity-id backend)))
+      (is-false (lime.x11::x11-backend-focus-root-override-p backend))
+      (is (equal "terminal" (presentation-focus-client-id (current-presentation world "main"))))
+      (is (equal '("editor" "terminal") (mapcar #'placement-client-id (view-placements (find-view world "development/code")))))
+      (is (validate-world world)))))
+
+(test head-send-to-self-or-empty-source-is-a-no-op
+  (with-membership-backend (backend world)
+    (let ((before (lime.persistence:snapshot-world world)))
+      (is (eq :close (ui-result-kind (lime.x11::%ui-request-client-send backend "main"))))
+      (is (equal "main" (x11-backend-focused-head-id backend)))
+      (is (equalp before (lime.persistence:snapshot-world world))))
+    (setf (lime.x11:x11-backend-focused-head-id backend) "other")
+    (let ((before (lime.persistence:snapshot-world world)))
+      (is (eq :close (ui-result-kind (lime.x11::%ui-request-client-send backend "main"))))
+      (is (equal "other" (x11-backend-focused-head-id backend)))
+      (is (equalp before (lime.persistence:snapshot-world world))))))
+
+(test membership-commands-live-under-windows-and-move-stays-on-current-activity
+  (with-membership-backend (backend world)
+    (let* ((window (find :window (lime.x11::%ui-key-path backend) :key #'ui-key-node-id))
+           (move (find :move-client-to-activity (ui-key-node-children window) :key #'ui-key-node-id))
+           (share (find :set-client-shared (ui-key-node-children window) :key #'ui-key-node-id))
+           (result (funcall (ui-key-node-action move))))
+      (is (char= #\m (ui-key-node-key move)))
+      (is (char= #\s (ui-key-node-key share)))
+      (is (eq :replace (ui-result-kind result)))
+      (is (eq :close (ui-result-kind (funcall (ui-candidate-action (first (ui-result-candidates result)))))))
+      (is (equal "development" (presentation-activity-id (current-presentation world "main"))))
+      (is (equal "chill" (client-activity-id (find-client world "editor"))))
+      ;; Portable destinations receive the window in their real arrangement,
+      ;; not in a second, hidden draft tied to the sending monitor.
+      (is-true (lease-for-client world "editor"))
+      (is (equal '("editor") (presentation-client-ids (current-presentation world "other"))))
+      (backend-activate-activity backend "chill" :head-id "main")
+      (is (equal '("editor") (presentation-leased-client-ids world (current-presentation world "main"))))
+      (is-true (validate-world world)))))
+
+(test stale-move-picker-does-not-act-on-another-window
+  (with-membership-backend (backend world)
+    (let* ((result (lime.x11::%ui-move-client-result backend "editor" "main"))
+           (choice (first (ui-result-candidates result))))
+      (backend-hide-client backend "editor")
+      (let ((snapshot (lime.persistence:snapshot-world world)))
+        (signals invalid-transition (funcall (ui-candidate-action choice)))
+        (is (equalp snapshot (lime.persistence:snapshot-world world)))))))
+
+(test shared-picker-takes-only-explicitly-and-can-summon-an-unavailable-slot-back
+  (with-membership-backend (backend world)
+    (backend-set-client-shared backend "terminal" t)
+    (backend-select-head backend "other")
+    (let* ((candidate (find '(:show-hidden-client "terminal") (lime.x11::%ui-hidden-client-candidates backend)
+                            :key #'ui-candidate-id :test #'equal))
+           (snapshot (lime.persistence:snapshot-world world))
+           (result (funcall (ui-candidate-action candidate))))
+      (is (search "Shared" (ui-candidate-label candidate)))
+      (is (eq :replace (ui-result-kind result)))
+      (is (equalp snapshot (lime.persistence:snapshot-world world)))
+      (signals invalid-transition (backend-show-client backend "terminal"))
+      (is (equalp snapshot (lime.persistence:snapshot-world world)))
+      (funcall (ui-candidate-action (first (ui-result-candidates result))))
+      (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "terminal"))))
+    (backend-select-head backend "main")
+    (is (find '(:show-hidden-client "terminal") (lime.x11::%ui-hidden-client-candidates backend)
+              :key #'ui-candidate-id :test #'equal))
+    (backend-show-client-taking backend "terminal")
+    (is (equal "main" (lime.x11::ewmh-active-head-id-for-client backend "terminal")))
+    (backend-hide-client backend "terminal")
+    (backend-select-head backend "other")
+    (backend-show-client backend "terminal")
+    (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "terminal")))
+    (is-true (validate-world world))))
+
+(test shared-head-transfer-and-attention-respect-the-existing-foreign-lease
+  (with-membership-backend (backend world)
+    (signals invalid-activity-membership (backend-transfer-focused-client-to-head backend "other"))
+    (is (equal "main" (x11-backend-focused-head-id backend)))
+    (backend-set-client-shared backend "editor" t)
+    (backend-transfer-focused-client-to-head backend "other")
+    (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "editor")))
+    (lime.x11::%attention-set-source backend "editor" 1 t)
+    (is (equal '("editor") (backend-attention-client-ids backend :activity-id "chill")))
+    (backend-attend-client backend "editor")
+    (is (equal "other" (lime.x11::x11-backend-focused-head-id backend)))
+    (is (equal "chill" (presentation-activity-id (current-presentation world "other"))))
+    (is (equal "editor" (presentation-focus-client-id (current-presentation world "other"))))
+    (is-true (validate-world world))))
+
+(test making-private-is-confirmed-and-keeps-the-current-activity
+  (with-membership-backend (backend world)
+    (backend-set-client-shared backend "editor" t)
+    (backend-show-client-taking backend "editor" :head-id "other")
+    (backend-save-view backend "chill/music" "Music" :head-id "other")
+    (let* ((snapshot (lime.persistence:snapshot-world world))
+           (source (current-presentation world "main"))
+           (target (current-presentation world "other"))
+           (placements (presentation-placements target))
+           (lease (lease-for-client world "editor"))
+           (result (lime.x11::%ui-set-client-sharing-result backend "editor" "other" nil)))
+      (is (eq :replace (ui-result-kind result)))
+      (is (search "Make private to Chill?" (lime.ui:ui-result-message result)))
+      (is (eq :cancel (ui-candidate-id (first (ui-result-candidates result)))))
+      (is (search "other Activities and their saved views" (ui-candidate-detail (second (ui-result-candidates result)))))
+      (is (equalp snapshot (lime.persistence:snapshot-world world)))
+      (funcall (ui-candidate-action (first (ui-result-candidates result))))
+      (is (equalp snapshot (lime.persistence:snapshot-world world)))
+      (is (eq :close (ui-result-kind (funcall (ui-candidate-action (second (ui-result-candidates result)))))))
+      (is-false (client-shared-p (find-client world "editor")))
+      (is (equal "chill" (client-activity-id (find-client world "editor"))))
+      (is (eq lease (lease-for-client world "editor")))
+      (is (eq source (current-presentation world "main")))
+      (is (eq target (current-presentation world "other")))
+      (is (eq placements (presentation-placements target)))
+      (is (equal "editor" (presentation-focus-client-id target)))
+      (is (equal "other" (x11-backend-focused-head-id backend)))
+      (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "development/code")))))
+      (is (equal '("editor") (mapcar #'placement-client-id (view-placements (find-view world "chill/music")))))
+      (is-false (lime.x11::%ui-hidden-client-candidates backend))
+      (backend-select-head backend "main")
+      (is-false (find '(:show-hidden-client "editor") (lime.x11::%ui-hidden-client-candidates backend)
+                      :key #'ui-candidate-id :test #'equal))
+      (signals invalid-transition (backend-show-client backend "editor"))
+      (is-true (validate-world world))
+      (let ((saved (lime.persistence:snapshot-world world)))
+        (is (equalp saved (lime.persistence:snapshot-world (lime.persistence:restore-world saved))))))))
+
+(test make-private-confirmation-rejects-changed-context
+  (dolist (change '(:head :focus :activity :hide :transfer :retire :shared :home))
+    (with-membership-backend (backend world)
+      (backend-set-client-shared backend "editor" t)
+      (backend-show-client-taking backend "editor" :head-id "other")
+      (let* ((result (lime.x11::%ui-set-client-sharing-result backend "editor" "other" nil))
+             (action (ui-candidate-action (second (ui-result-candidates result)))))
+        (ecase change
+          (:head (setf (x11-backend-focused-head-id backend) "main"))
+          ;; Even an adapter-only focus change without a model revision is stale.
+          (:focus (setf (presentation-focus-client-id (current-presentation world "other")) nil))
+          (:activity (open-activity-draft world "other" "development"))
+          (:hide (backend-hide-client backend "editor"))
+          (:transfer (backend-show-client-taking backend "editor" :head-id "main"))
+          (:retire (retire-client world "editor"))
+          (:shared (set-client-shared world "editor" nil))
+          (:home (move-client-to-activity world "editor" "chill")))
+        (let ((before (lime.persistence:snapshot-world world)))
+          (is (eq :keep-open (ui-result-kind (funcall action))))
+          (is (equalp before (lime.persistence:snapshot-world world))))))))
+
+(test non-prompting-private-command-and-sharing-alias-keep-the-current-home
+  (dolist (explicit-head-p '(nil t))
+    (with-membership-backend (backend world)
+      (backend-set-client-shared backend "editor" t)
+      (backend-show-client-taking backend "editor" :head-id "other")
+      (when explicit-head-p (backend-select-head backend "main"))
+      (let ((before (lime.persistence:snapshot-world world)))
+        (signals stale-transition-plan
+          (backend-make-client-private backend "editor" :head-id "other" :expected-revision -1))
+        (is (equalp before (lime.persistence:snapshot-world world)))
+        (when explicit-head-p
+          (signals invalid-transition (backend-set-client-shared backend "editor" nil))
+          (is (equalp before (lime.persistence:snapshot-world world)))))
+      (if explicit-head-p (backend-make-client-private backend "editor" :head-id "other")
+          (backend-set-client-shared backend "editor" nil))
+      (is (equal "chill" (client-activity-id (find-client world "editor"))))
+      (is (equal (if explicit-head-p "main" "other") (x11-backend-focused-head-id backend)))
+      (is-false (client-shared-p (find-client world "editor")))
+      (is (validate-world world)))))
+
+(test delete-activity-is-discoverable-confirmed-and-non-mutating-until-approved
+  (with-membership-backend (backend world)
+    (create-activity world "old" "Old")
+    (let* ((node (find :activity (lime.x11::%ui-key-path backend) :key #'ui-key-node-id))
+           (delete-node (find :delete-activity (ui-key-node-children node) :key #'ui-key-node-id))
+           (snapshot (lime.persistence:snapshot-world world))
+           (picker (funcall (ui-key-node-action delete-node))))
+      (is (char= #\d (ui-key-node-key delete-node)))
+      (is (find :delete-activity (lime.x11::%command-palette-candidates backend) :key #'ui-candidate-id))
+      (let* ((candidate (find '(:delete-activity "old") (ui-result-candidates picker) :key #'ui-candidate-id :test #'equal))
+             (confirmation (funcall (ui-candidate-action candidate))))
+        (is (eq :replace (ui-result-kind confirmation)))
+        (is (eq :cancel (ui-candidate-id (first (ui-result-candidates confirmation)))))
+        (funcall (ui-candidate-action (first (ui-result-candidates confirmation))))
+        (is (equalp snapshot (lime.persistence:snapshot-world world)))
+        (is (eq :close (ui-result-kind (funcall (ui-candidate-action (second (ui-result-candidates confirmation)))))))
+        (signals unknown-entity (find-activity world "old"))
+        (is (equal "development" (presentation-activity-id (current-presentation world "main"))))
+        (is (equal "chill" (presentation-activity-id (current-presentation world "other"))))))))
+
+(test activity-delete-menu-explains-blockers-and-rejects-stale-confirmations
+  (with-membership-backend (backend world)
+    (let ((snapshot (lime.persistence:snapshot-world world)))
+      (is (eq :keep-open (ui-result-kind (lime.x11::%ui-delete-activity-result backend "development"))))
+      (is (eq :keep-open (ui-result-kind (lime.x11::%ui-delete-activity-result backend "chill"))))
+      (is (equalp snapshot (lime.persistence:snapshot-world world))))
+    (create-activity world "old" "Old")
+    (let* ((confirmation (lime.x11::%ui-delete-activity-result backend "old"))
+           (action (ui-candidate-action (second (ui-result-candidates confirmation)))))
+      (create-client world "new" "old")
+      (let ((snapshot (lime.persistence:snapshot-world world)))
+        (is (eq :keep-open (ui-result-kind (funcall action))))
+        (is (equalp snapshot (lime.persistence:snapshot-world world))))
+      (retire-client world "new")
+      (delete-activity world "old")
+      (create-activity world "old" "New activity, reused id")
+      (is (eq :keep-open (ui-result-kind (funcall action))))
+      (is (equal "New activity, reused id" (activity-name (find-activity world "old")))))))

test/x11-navigation-smoke.lisp

@@ -0,0 +1,261 @@
+;;;; Real numeric key grabs, lease prompts, and restart persistence on OWN Xvfb.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/x11")
+(lime.config:defconfiguration navigation-smoke-config (:navigation-keys))
+
+(handler-case
+ (let* ((directory (uiop:ensure-directory-pathname
+                    (string-trim '(#\Newline)
+                                 (uiop:run-program '("mktemp" "-d" "/tmp/lime-navigation-XXXXXX") :output :string))))
+        (path (merge-pathnames "session.sexp" directory))
+        (server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x622x24" "-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))
+               (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 600 :height 622)
+                            (lime.x11:make-x11-head :head-id "right" :x 600 :y 0 :width 600 :height 622))))
+          (setf clients (xlib:open-default-display display-name))
+          (labels ((check (truth label) (assert truth () "Navigation: ~A" label) (incf checks))
+                   (world () (lime.x11:x11-backend-world backend))
+                   (current (&optional (head "left")) (lime.core:current-presentation (world) head))
+                   (activity () (lime.core:presentation-activity-id (current)))
+                   (view () (lime.core:presentation-source-view-id (current)))
+                   (session () (lime.x11::x11-backend-ui-session backend))
+                   (start ()
+                     (setf backend (lime.x11:start-lime :display-name display-name :heads heads
+                                                       :install-default-keybindings-p nil :session-file path))
+                     (lime.x11:apply-lime-configuration backend navigation-smoke-config))
+                   (stop () (lime.x11:stop-backend backend) (setf backend nil))
+                   (pump ()
+                     (xlib:display-finish-output clients)
+                     (let ((turns 0) (display (lime.x11::x11-backend-display backend)))
+                       (lime.x11:run-event-loop backend :timeout 0.005
+                        :before-event (lambda (b)
+                                        (assert (< (incf turns) 500) () "Navigation event queue did not settle.")
+                                        (xlib:display-finish-output display)
+                                        (unless (xlib:event-listen display)
+                                          (setf (lime.x11::x11-backend-running-p b) nil))))))
+                   (tap (number &optional shift-p)
+                     (let* ((display (lime.x11::x11-backend-display backend))
+                            (super (first (nth-value 6 (xlib:modifier-mapping display))))
+                            (shift (first (nth-value 0 (xlib:modifier-mapping display))))
+                            (key (xlib:keysym->keycodes display (+ (char-code #\0) (mod number 10)))))
+                       (check (and super shift key) "physical modifier and digit keycodes found")
+                       (xlib/xtest:fake-key-event clients super t)
+                       (when shift-p (xlib/xtest:fake-key-event clients shift t))
+                       (xlib/xtest:fake-key-event clients key t)
+                       (xlib/xtest:fake-key-event clients key nil)
+                       (when shift-p (xlib/xtest:fake-key-event clients shift nil))
+                       (xlib/xtest:fake-key-event clients super nil)
+                       (pump)))
+                   (choose (id)
+                     (let ((candidate (find id (lime.ui:ui-session-candidates (session))
+                                            :key #'lime.ui:ui-candidate-id :test #'equal)))
+                       (check candidate (format nil "collision choice ~S exists" id))
+                       (lime.x11::%perform-ui-action backend (list :candidate candidate)))
+                     (pump))
+                   (click-region (head region)
+                     (let* ((bar (gethash head (lime.x11::x11-backend-head-bars backend)))
+                            (window (lime.x11::x11-head-bar-window bar)))
+                       (xlib/xtest:fake-motion-event clients
+                        (+ (xlib:drawable-x window)
+                           (floor (+ (lime.x11::x11-head-bar-hit-region-left region)
+                                     (lime.x11::x11-head-bar-hit-region-right region)) 2))
+                        (+ (xlib:drawable-y window) 10))
+                       (pump)
+                       (check (lime.x11::x11-head-bar-pointer-hand-p bar) "activity target has hand cursor")
+                       (xlib/xtest:fake-button-event clients 1 t)
+                       (xlib/xtest:fake-button-event clients 1 nil)
+                       (pump)))
+                   (click-activity (head id)
+                     (let* ((bar (gethash head (lime.x11::x11-backend-head-bars backend)))
+                            (entries (lime.x11::%bar-activity-entries backend head))
+                            (index (position id entries :key (lambda (e) (getf e :id)) :test #'equal))
+                            (region (nth (1+ index) (lime.x11::x11-head-bar-hit-regions bar))))
+                       ;; This fixture has only two entries at this point; no
+                       ;; clipping/overflow is allowed to hide a wrong target.
+                       (check (= (- (lime.x11::x11-head-bar-hit-region-right region)
+                                    (lime.x11::x11-head-bar-hit-region-left region))
+                                 (lime.x11::%text-width (lime.x11::x11-head-bar-font bar)
+                                                       (getf (nth index entries) :text)))
+                              "click region matches entire measured Activity label")
+                       (click-region head region)))
+                   (spawn ()
+                     (let ((window (xlib:create-window
+                                    :parent (xlib:screen-root (xlib:display-default-screen clients))
+                                    :x 0 :y 0 :width 100 :height 100)))
+                       (xlib:map-window window) (pump)
+                       (lime.x11::%backend-client-id backend window))))
+            (start)
+            (lime.x11:backend-select-head backend "left")
+            (let ((right-id (lime.core:presentation-id (current "right"))))
+              (check (= 1 (lime.x11:backend-activity-slot backend "scratch")) "Scratch starts at 1")
+              (lime.x11:backend-start-activity backend "work" "Work")
+              (let* ((a (spawn))
+                     (code (lime.x11:backend-save-named-view backend "Code"))
+                     (code-id (lime.core:presentation-source-view-id code))
+                     (b (spawn))
+                     (dirty-id (lime.core:presentation-id (current))))
+                (lime.core:create-view (world) "work/docs" "work" "Docs"
+                                      (list (lime.core:make-placement :client-id b)))
+                (lime.x11:backend-set-view-slot backend "work/docs" 3)
+                (check (lime.core:presentation-dirty-p (current)) "Code has unsaved new window")
+                (lime.x11:backend-start-activity backend "chill" "Chill")
+                (lime.x11:backend-save-named-view backend "Play")
+                (tap 2)
+                (check (equal "work" (activity)) "Super-2 selects Work")
+                (check (equal dirty-id (lime.core:presentation-id (current))) "returns to identical dirty presentation")
+                (check (equal code-id (view)) "Activity return preserves selected View")
+                (check (member b (lime.core:presentation-client-ids (current)) :test #'equal) "unsaved window retained")
+                (check (equal right-id (lime.core:presentation-id (current "right"))) "other Head unchanged")
+                (check (not (session)) "successful switch has no menu")
+                (let ((before (lime.persistence:snapshot-world (world))))
+                  (tap 2) (tap 1 t)
+                  (check (equalp before (lime.persistence:snapshot-world (world))) "current Activity/View keys do not reset edits"))
+                (tap 3 t)
+                (check (equal "work/docs" (view)) "Super-Shift-3 recalls local Docs")
+                (check (equal (list b) (lime.core:presentation-client-ids (current))) "checkpoint contents recalled")
+                (tap 3)
+                (tap 1 t)
+                (check (equal "chill" (activity)) "same shifted number stays in Chill")
+                (check (equal "Play" (lime.core:view-name (lime.core:find-view (world) (view)))) "local 1 means Chill's Play")
+                (lime.x11:backend-set-activity-slot backend "work" 3)
+                (lime.x11:backend-set-view-slot backend code-id 10)
+                (tap 3) (tap 10 t)
+                (check (equal code-id (view)) "Super-3 follows Activity order; Super-Shift-0 uses stable View slot 10")
+                ;; A distinct View containing A may hold the lease on right.
+                (lime.core:create-view (world) "work/right" "work" "Right"
+                                      (list (lime.core:make-placement :client-id a)))
+                (lime.x11:backend-extend-activity-to-head backend "work" "right")
+                (lime.x11:backend-activate-view backend "work/right" :head-id "right" :policy :take)
+                (tap 3 t)
+                (let ((before (lime.persistence:snapshot-world (world))))
+                  (tap 10 t)
+                  (check (session) "contested checkpoint opens conflict picker")
+                  (check (equalp before (lime.persistence:snapshot-world (world))) "conflict does not steal or mutate")
+                  (choose :cancel)
+                  (check (equalp before (lime.persistence:snapshot-world (world))) "cancel leaves both Heads alone"))
+                (tap 10 t)
+                (choose (list :activate-partially code-id))
+                (check (member a (lime.core:presentation-unavailable-client-ids (current)) :test #'equal)
+                       "partial recall leaves leased window elsewhere")
+                ;; Activity return keeps current locations, not omitted View requests.
+                (tap 2)
+                (tap 3)
+                (check (not (session)) "Activity resume needs no conflict menu")
+                (check (null (lime.core:presentation-client-ids (current))) "partial arrangement stays empty")
+                (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend a)) "Activity resume leaves other Head's window alone")
+                ;; Recalling the saved checkpoint is a distinct, explicit restore.
+                (tap 3 t)
+                (tap 10 t)
+                (choose (list :activate-taking code-id))
+                (check (equal "left" (lime.x11::ewmh-active-head-id-for-client backend a)) "explicit take moves one lease")
+                (check (null (lime.core:presentation-client-ids (current "right"))) "source no longer retains a claim")
+                (lime.core:set-presentation-layout-mode (world) (lime.core:presentation-id (current)) :monocle)
+                (lime.x11:apply-active-presentation backend)
+                ;; Never mount the SAME View on two Heads, even empty/partial.
+                (lime.x11:backend-select-head backend "right")
+                (lime.x11:backend-select-view-slot backend 10)
+                (check (session) "already-mounted View gives visible explanation")
+                (check (search "already open" (lime.ui:ui-session-status (session))) "mount conflict explained")
+                (lime.x11:backend-close-command-palette backend)
+                (lime.x11:backend-select-head backend "left")
+                (check (equal "Work" (lime.x11::%bar-presentation-label backend "left")) "bar shows Activity without checkpoint suffix")
+                (check (lime.core:presentation-dirty-p (current)) "bar does not clear dirty edits")
+                (let ((slots (lime.x11:backend-navigation-slots backend)))
+                  (lime.x11:backend-save-session backend)
+                  (stop) (start) (pump)
+                  (check (not (getf (lime.x11:backend-session-status backend) :blocked-p)) "new session schema restores")
+                  (check (equal slots (lime.x11:backend-navigation-slots backend)) "slot assignments survive restart")
+                  (tap 2) (tap 3)
+                  (check (equal code-id (view)) "last View resumes after restart")
+                  (check (equal "Work" (lime.x11::%bar-presentation-label backend "left"))
+                         "Activity-only bar survives persistence")
+                  (check (lime.core:presentation-dirty-p (current)) "dirty edits survive navigation and persistence"))
+                (lime.x11:backend-switch-to-activity backend "scratch")
+                (lime.x11:backend-delete-activity backend "chill")
+                (check (= 2 (lime.x11:backend-activity-slot backend "work")) "deleting the middle Activity shifts Work to position 2")
+                (tap 2)
+                (check (equal "work" (activity)) "Super-2 now selects the second Activity")
+                (check (= 10 (lime.x11:backend-view-slot backend code-id)) "Activity compaction leaves View slots alone")
+                (let ((slots (lime.x11:backend-navigation-slots backend)))
+                  (lime.x11:backend-save-session backend)
+                  (stop) (start) (pump)
+                  (check (equal slots (lime.x11:backend-navigation-slots backend)) "compacted order survives restart"))
+                (lime.x11:backend-start-activity backend "game" "A new Game")
+                (check (= 3 (lime.x11:backend-activity-slot backend "game")) "new Activity appends even with an earlier alphabetical name")
+                (tap 2) (tap 3)
+                (check (equal "game" (activity)) "Super-3 selects newly appended Activity")
+                (tap 2)
+                (lime.x11:backend-delete-activity backend "game")
+                (check (null (lime.x11::x11-backend-last-command-error backend)) "no key dispatch errors")
+                (check (lime.core:validate-world (world)) "world invariants hold")
+                ;; Actual pointer events use the clicked Head, restore its
+                ;; dirty arrangement, and preserve the other Head's state.
+                (let ((right-id (lime.core:presentation-id (current "right"))))
+                  (click-activity "left" "work")
+                  (check (equal "work" (activity)) "bar click resumes Work")
+                  (check (equal code-id (view)) "bar click restores dirty Code")
+                  (check (equal right-id (lime.core:presentation-id (current "right"))) "bar does not switch other Head")
+                  (let ((before (lime.persistence:snapshot-world (world))))
+                    (click-activity "left" "work")
+                    (check (equalp before (lime.persistence:snapshot-world (world))) "active tab click does not reset checkpoint")
+                    (check (not (eq :pointer-root (xlib:input-focus clients))) "active tab restores client input focus")))
+                (click-activity "right" "scratch")
+                (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "offset right bar selects right Head")
+                (check (equal "scratch" (lime.core:presentation-activity-id (current "right"))) "right tab switches only right Activity")
+                (let ((left-id (lime.core:presentation-id (current))))
+                  (click-activity "right" "work")
+                  (check (not (session)) "bar return has no stale lease conflict")
+                  (check (null (lime.core:presentation-client-ids (current "right"))) "moved window is absent from old layout")
+                  (check (equal left-id (lime.core:presentation-id (current))) "bar return leaves other activity unchanged")
+                  (check (equal "left" (lime.x11::ewmh-active-head-id-for-client backend a)) "bar return does not reclaim moved window"))
+                (lime.x11:backend-select-head backend "left")
+                ;; Simulate a session produced before navigation existed.
+                (stop)
+                (let ((store (lime.persistence:open-session-store path)))
+                  (unwind-protect
+                       (let ((data (lime.persistence:read-session-store store)))
+                         (remf data :navigation)
+                         (remf data :activity-navigation)
+                         (setf (getf data :version) 1)
+                         (lime.persistence:write-session-store store data))
+                    (lime.persistence:close-session-store store)))
+                (start) (pump)
+                (check (not (getf (lime.x11:backend-session-status backend) :blocked-p)) "legacy session migrates")
+                (check (= 1 (lime.x11:backend-activity-slot backend "scratch")) "legacy Scratch gets first slot")
+                (check (= 2 (lime.x11:backend-activity-slot backend "work")) "legacy remaining Activity gets second position")
+                (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend))) "migration reconnects real windows")
+                ;; Many long names must not push the active tab off the bar.
+                (dotimes (n 15)
+                  (lime.core:create-activity (world) (format nil "extra~D" n)
+                                            (format nil "Long extra activity ~D" n)))
+                (lime.x11::apply-active-presentation backend)
+                (pump)
+                (let ((tenth (first (nth 9 (getf (lime.x11:backend-navigation-slots backend) :activities)))))
+                  (tap 10)
+                  (check (equal tenth (activity)) "Super-0 still selects position 10 with many Activities")
+                  (tap 2))
+                (let* ((bar (gethash "left" (lime.x11::x11-backend-head-bars backend)))
+                       (regions (lime.x11::x11-head-bar-hit-regions bar))
+                       (overflow (nth (- (length regions) 2) regions)))
+                  (check (= (lime.x11::%text-width (lime.x11::x11-head-bar-font bar) "…")
+                            (- (lime.x11::x11-head-bar-hit-region-right overflow)
+                               (lime.x11::x11-head-bar-hit-region-left overflow))) "overflow gets its own measured target")
+                  (click-region "left" overflow)
+                  (check (every (lambda (c) (eq :activity (first (lime.ui:ui-candidate-id c))))
+                                (lime.ui:ui-session-candidates (session))) "overflow shows only Activities")
+                  (check (= 17 (length (lime.ui:ui-session-candidates (session)))) "overflow retains all Activities")
+                  (choose '(:activity "extra14"))
+                  (check (equal "extra14" (activity)) "overflow can reach clipped Activity"))
+                (check (null (lime.x11::x11-backend-last-command-error backend)) "bar navigation has no errors")
+                (format t "~&Navigation 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* "~&Navigation smoke failed: ~A~%" condition)
+   (uiop:quit 1)))

test/x11-navigation.lisp

@@ -0,0 +1,266 @@
+(in-package #:lime.x11.test)
+(in-suite lime-x11-suite)
+
+(lime.config:defconfiguration numbered-navigation-fixture
+  (:navigation-keys))
+
+(test numbered-navigation-expands-to-configurable-ordinary-bindings
+  (let ((config numbered-navigation-fixture))
+    (is (= 20 (length (lime-configuration-commands config))))
+    (is (= 20 (length (lime-configuration-bindings config))))
+    (is (eq config (lime.x11::%validate-lime-configuration config)))
+    (dolist (kind '(:activity :view))
+      (loop for n from 1 to 10 for key across "1234567890" do
+        (let* ((id (intern (format nil "NAVIGATE-~A-~D" kind n) :keyword))
+               (binding (find id (lime-configuration-bindings config) :key #'configuration-binding-command-id)))
+          (is (eql key (configuration-binding-key binding)))
+          (is (equal (if (eq kind :view) '(:mod-4 :shift) '(:mod-4))
+                     (configuration-binding-modifiers binding)))))))
+  (signals error
+    (macroexpand-1 '(lime.config:defconfiguration invalid-navigation (:navigation-keys :typo t)))))
+
+(test activity-positions-compact-while-view-slots-stay-local-and-stable
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)))
+    (create-activity world "scratch" "Scratch")
+    (create-activity world "chill" "Chill")
+    (create-view world "chill/code" "chill" "Code" nil)
+    (let ((before (lime.persistence:snapshot-world world)))
+      (is (= 1 (backend-activity-slot backend "scratch")))
+      (is (= 2 (backend-activity-slot backend "chill")))
+      (is (= 3 (backend-activity-slot backend "development")))
+      (is (= 1 (backend-view-slot backend "development/code")))
+      (is (= 1 (backend-view-slot backend "chill/code")))
+      (backend-set-activity-slot backend "development" 1)
+      (is (= 1 (backend-activity-slot backend "development")))
+      (is (= 3 (backend-activity-slot backend "scratch")))
+      (is (equalp before (lime.persistence:snapshot-world world))))
+    (delete-activity world "chill")
+    (is (= 2 (backend-activity-slot backend "scratch")))
+    (create-activity world "new" "A new task")
+    (is (= 3 (backend-activity-slot backend "new")))
+    (create-view world "development/docs" "development" "Docs" nil)
+    (is (= 2 (backend-view-slot backend "development/docs")))
+    (backend-set-view-slot backend "development/docs" 1)
+    (is (= 1 (backend-view-slot backend "development/docs")))
+    (is (= 2 (backend-view-slot backend "development/code")))
+    (signals invalid-transition (backend-set-activity-slot backend "new" 0))
+    (signals invalid-transition (backend-set-activity-slot backend "new" 4))
+    (loop for n from 1 to 12 do (create-activity world (format nil "extra~D" n) "Extra"))
+    (is (= 15 (length (getf (backend-navigation-slots backend) :activities))))
+    (is (null (backend-view-slot backend "chill/code")))
+    (let ((before (lime.persistence:snapshot-world world)))
+      (is (null (backend-select-activity-slot backend 999)))
+      (is (null (backend-select-view-slot backend 999)))
+      (is (equalp before (lime.persistence:snapshot-world world))))))
+
+(test navigation-persistence-validates-scoped-uniqueness-and-resume-targets
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)))
+    (create-activity world "chill" "Chill")
+    (create-view world "chill/code" "chill" "Code" nil)
+    (backend-set-activity-slot backend "development" 2)
+    (backend-set-view-slot backend "development/code" 10)
+    (let* ((data (lime.x11::%navigation-snapshot backend))
+           (restored (lime.x11::%navigation-read-data data world)))
+      (is (equal data (list :activities (lime.x11::navigation-state-activities restored)
+                            :views (lime.x11::navigation-state-views restored)
+                            :resume (lime.x11::navigation-state-resume restored))))
+      (dolist (bad '((:activities (("development" 1) ("chill" 1)) :views nil :resume nil)
+                     (:activities (("development" 0)) :views nil :resume nil)
+                     (:activities (("missing" 1)) :views nil :resume nil)
+                     (:activities nil :views (("development/code" 1) ("development/code" 2)) :resume nil)))
+        (signals error (lime.x11::%navigation-read-data bad world)))
+      (let ((bad (copy-tree data)))
+        (setf (second (first (getf bad :resume))) "chill")
+        (signals error (lime.x11::%navigation-read-data bad world)))
+      (setf (gethash backend lime.x11::*backend-navigation-states*) restored)
+      (is (= 2 (backend-activity-slot backend "development")))
+      (is (= 10 (backend-view-slot backend "development/code"))))))
+
+(test activity-compaction-preserves-order-without-mutating-input
+  (let* ((existing '(("c" 9) ("a" 1) ("removed" 4)))
+         (before (copy-tree existing))
+         (result (lime.x11::%navigation-activity-slots existing '("new" "a" "c" "last"))))
+    (is (equal '(("a" 1) ("c" 2) ("new" 3) ("last" 4)) result))
+    (is (equal before existing))
+    (setf (second (first result)) 999)
+    (is (equal before existing))
+    (is (null (lime.x11::%navigation-activity-slots existing nil)))))
+
+(test old-sparse-activity-shortcuts-load-in-bar-order-without-changing-view-slots
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)))
+    (create-activity world "chill" "Chill")
+    (let* ((data '(:activities (("development" 8) ("chill" 3))
+                  :views (("development/code" 10)) :resume nil))
+           (before-data (copy-tree data))
+           (before-world (lime.persistence:snapshot-world world))
+           (state (lime.x11::%navigation-read-data data world)))
+      (is (equal '(("chill" 1) ("development" 2)) (lime.x11::navigation-state-activities state)))
+      (is (equal before-data data))
+      (setf (gethash backend lime.x11::*backend-navigation-states*) state)
+      (is (= 2 (backend-activity-slot backend "development")))
+      (is (= 10 (backend-view-slot backend "development/code")))
+      (is (equalp before-world (lime.persistence:snapshot-world world)))
+      (create-activity world "new" "Alphabetically first")
+      (is (= 3 (backend-activity-slot backend "new")))
+      (let ((snapshot (lime.x11::%navigation-snapshot backend)))
+        (is (equal (getf snapshot :activities)
+                   (lime.x11::navigation-state-activities (lime.x11::%navigation-read-data snapshot world))))))))
+
+(test activity-deletion-compacts-before-append-even-without-an-intermediate-render
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)))
+    (create-activity world "first" "A first")
+    (create-activity world "last" "Z last")
+    (backend-set-view-slot backend "development/code" 9)
+    (let ((state (lime.x11::%navigation-state backend)))
+      (is (equal '(("first" 1) ("development" 2) ("last" 3)) (lime.x11::navigation-state-activities state)))
+      (let ((generation (lime.x11::navigation-state-generation state)))
+        (delete-activity world "first")
+        (create-activity world "new" "A new")
+        (let ((before (lime.persistence:snapshot-world world)))
+          (is (equal '(("development" 1) ("last" 2) ("new" 3))
+                     (getf (backend-navigation-slots backend) :activities)))
+          (is (> (lime.x11::navigation-state-generation state) generation))
+          (is (= 9 (backend-view-slot backend "development/code")))
+          (dolist (head-id '("main"))
+            (is (equal '("development" "last" "new")
+                       (mapcar (lambda (entry) (getf entry :id)) (lime.x11::%bar-activity-entries backend head-id)))))
+          (is (equalp before (lime.persistence:snapshot-world world))))))))
+
+(test numbered-current-activity-and-view-do-not-reset-dirty-edits
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))
+         (p (current-presentation world "main")))
+    (set-presentation-layout-mode world (presentation-id p) :monocle)
+    (let ((before (lime.persistence:snapshot-world world)))
+      (is (eq :close (ui-result-kind (backend-select-activity-slot backend 1))))
+      (is (eq :close (ui-result-kind (backend-select-view-slot backend 1))))
+      (is (equalp before (lime.persistence:snapshot-world world)))
+      (is (presentation-dirty-p p)))))
+
+(test navigation-session-envelope-migrates-v1-without-inventing-views
+  (let* ((world (make-world))
+         (activity (create-activity world "scratch" "Scratch"))
+         (legacy (list :format :lime-session :version 1
+                       :world (lime.persistence:snapshot-world world)
+                       :server-token (make-string 32 :initial-element #\A)
+                       :clients nil :focused-head nil :focus-root nil)))
+    (is (equal (activity-id activity)
+               (activity-id (first (list-activities (lime.x11::%validate-session-envelope legacy))))))
+    (let ((modern (copy-tree legacy)))
+      (setf (getf modern :version) 2
+            (getf modern :navigation) '(:activities (("scratch" 1)) :views nil :resume nil))
+      (is (null (activity-view-ids
+                 (find-activity (lime.x11::%validate-session-envelope modern) "scratch"))))
+      (setf (getf modern :navigation) '(:activities (("missing" 1)) :views nil :resume nil))
+      (signals error (lime.x11::%validate-session-envelope modern)))))
+
+(test activity-strip-highlights-the-local-activity-without-view-suffixes
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)))
+    (create-activity world "chill" "Chill")
+    (create-head world "right")
+    (setf (gethash "right" (lime.x11::x11-backend-heads backend))
+          (make-x11-head :head-id "right" :x 840 :y 30 :width 800 :height 600)
+          (lime.x11::x11-backend-head-ids backend) '("main" "right"))
+    (open-activity-draft world "right" "chill")
+    (backend-set-activity-slot backend "development" 1)
+    (let* ((before (lime.persistence:snapshot-world world))
+           (left (lime.x11::%bar-activity-entries backend "main"))
+           (right (lime.x11::%bar-activity-entries backend "right")))
+      (is (equal '("Development" "Chill") (mapcar (lambda (e) (getf e :text)) left)))
+      (is (equal '("Development" "Chill") (mapcar (lambda (e) (getf e :text)) right)))
+      (is (getf (first left) :active-p))
+      (is (getf (second right) :active-p))
+      (is (equalp before (lime.persistence:snapshot-world world))))
+    (open-activity-draft world "right" "development")
+    (is (equal "Development" (getf (first (lime.x11::%bar-activity-entries backend "right")) :text)))
+    (is (equal "Development" (getf (first (lime.x11::%bar-activity-entries backend "main")) :text)))))
+
+(defun choose-view-update (result id)
+  (funcall (ui-candidate-action (find id (ui-result-candidates result)
+                                     :key #'ui-candidate-id :test #'equal))))
+
+(test checkpoint-update-picker-is-local-explicit-and-nondestructive-until-confirmed
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))
+         (p (current-presentation world "main")))
+    (create-view world "development/docs" "development" "Docs" nil)
+    (create-activity world "chill" "Chill")
+    (create-view world "chill/code" "chill" "Code" nil)
+    ;; The source label is not required, and must not silently pick the target.
+    (setf (presentation-source-view-id p) nil)
+    (set-presentation-layout-mode world (presentation-id p) :monocle)
+    (let* ((before (lime.persistence:snapshot-world world))
+           (picker (lime.x11::%ui-view-update-picker-result backend))
+           (confirmation (choose-view-update picker '(:update-view "development/docs"))))
+      (is (equal '((:update-view "development/code") (:update-view "development/docs"))
+                 (mapcar #'ui-candidate-id (ui-result-candidates picker))))
+      (is (lime.x11::%ui-update-current-view-candidate backend))
+      (is (eq :cancel (ui-candidate-id (first (ui-result-candidates confirmation)))))
+      (is (search "Docs" (lime.ui:ui-result-message confirmation)))
+      (is (eq :close (ui-result-kind (choose-view-update confirmation :cancel))))
+      (is (equalp before (lime.persistence:snapshot-world world)))
+      (is (eq :close (ui-result-kind
+                     (choose-view-update confirmation '(:confirm-update-view "development/docs")))))
+      (is (eq :monocle (view-layout-mode (find-view world "development/docs"))))
+      (is (equal (presentation-client-ids p)
+                 (mapcar #'placement-client-id (view-placements (find-view world "development/docs"))))))
+    (is (eq :manual (view-layout-mode (find-view world "development/code"))))
+    (is (null (view-placements (find-view world "chill/code"))))
+    (is (eq p (current-presentation world "main")))
+    (is (null (presentation-source-view-id p)))
+    (is (validate-world world))))
+
+(test checkpoint-update-rejects-changed-arrangements-and-heads
+  (dolist (change '(:model :head))
+    (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))
+           (picker (lime.x11::%ui-view-update-picker-result backend))
+           (confirmation (choose-view-update picker '(:update-view "development/code"))))
+      (ecase change
+        (:model (set-presentation-layout-mode world (presentation-id (current-presentation world "main")) :monocle))
+        (:head (setf (lime.x11::x11-backend-focused-head-id backend) "other")))
+      (let ((before (lime.persistence:snapshot-world world)))
+        (is (eq :keep-open (ui-result-kind (choose-view-update picker '(:update-view "development/code")))))
+        (is (eq :keep-open (ui-result-kind (choose-view-update confirmation '(:confirm-update-view "development/code")))))
+        (is (equalp before (lime.persistence:snapshot-world world)))))))
+
+(test checkpoint-update-picker-explains-an-empty-library
+  (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)))
+    (create-activity world "empty" "Empty")
+    (open-activity-draft world "main" "empty")
+    (let* ((before (lime.persistence:snapshot-world world))
+           (result (lime.x11::%ui-view-update-picker-result backend)))
+      (is (null (ui-result-candidates result)))
+      (is (search "Save a new checkpoint first" (lime.ui:ui-result-message result)))
+      (is (null (lime.x11::%ui-update-current-view-candidate backend)))
+      (is (equalp before (lime.persistence:snapshot-world world))))))
+
+(test activity-strip-fitting-is-bounded-ordered-and-keeps-the-active-tab
+  (let* ((entries (list (list :id "one" :text "1 One")
+                        (list :id "two" :text "2 Two")
+                        (list :id "three" :text "3 Three")
+                        (list :id "four" :text "4 Four:Draft*" :active-p t)
+                        (list :id "five" :text "5 Five")))
+         (before (copy-tree entries))
+         (measure (lambda (text) (* 5 (length text)))))
+    (loop for width from 0 to 360 by 9 do
+      (multiple-value-bind (text prefix used runs)
+          (lime.x11::%fit-bar-activities entries width measure #'lime.x11::%bar-short-text)
+        (declare (ignore text prefix))
+        (is (<= 0 used width))
+        (is (loop for run in runs always (<= 0 (getf run :x) (+ (getf run :x) (getf run :width)) width)))
+        (is (loop for (a b) on runs while b
+                  always (< (+ (getf a :x) (getf a :width)) (getf b :x))))
+        (when (>= width 45)
+          (is (find "four" runs :key (lambda (r) (getf (getf r :entry) :id)) :test #'equal)))
+        (when (>= width 300)
+          (is (= 5 (length runs)))
+          (is (notany (lambda (r) (getf r :overflow-p)) runs)))))
+    (is (equal entries before))
+    (let* ((fit (lambda (ignored budget ignored-measure)
+                  (declare (ignore ignored ignored-measure))
+                  (lime.x11::%fit-bar-activities entries budget measure #'lime.x11::%bar-short-text)))
+           (layout (lime.x11::%bar-text-layout
+                    420 "" "[]=" "Some window" (make-string 100 :initial-element #\s) measure
+                    :label-fit fit :minimum-label-width 96)))
+      (is (getf layout :label-runs))
+      (is (find-if (lambda (r) (getf r :overflow-p)) (getf layout :label-runs)))
+      (is (<= (getf layout :label-x) (getf layout :layout-x) (getf layout :title-left)
+              (getf layout :title-right) (getf layout :status-x))))))

test/x11-package.lisp

@@ -0,0 +1,3 @@
+(defpackage #:lime.x11.test
+  (:use #:cl #:fiveam #:lime.core #:lime.ui #:lime.x11)
+  (:export #:run-tests))

test/x11-persistence-smoke.lisp

@@ -0,0 +1,199 @@
+;;;; Owned Xvfb only: disk restoration, surviving hidden clients, identity safety,
+;;;; autosave, unavailable leases, topology changes, and corrupt/I/O-failing files.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/dev")
+
+(handler-case
+ (let* ((directory (uiop:ensure-directory-pathname
+                    (string-trim '(#\Newline) (uiop:run-program '("mktemp" "-d" "/tmp/lime-persistence-XXXXXX") :output :string))))
+        (path (merge-pathnames "session.sexp" directory))
+        (server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x600x24" "-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))
+               (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 500 :height 600)
+                            (lime.x11:make-x11-head :head-id "right" :x 500 :y 0 :width 500 :height 600))))
+          (setf clients (xlib:open-default-display display-name))
+          (let* ((root (xlib:screen-root (xlib:display-default-screen clients)))
+                 (windows (loop repeat 4 collect (xlib:create-window :parent root :x 10 :y 10 :width 100 :height 80 :border-width 7)))
+                 (ids nil) (saved nil))
+            (labels ((check (truth label) (assert truth () "Persistence: ~A" label) (incf checks))
+                     (world () (lime.x11:x11-backend-world backend))
+                     (current (head) (lime.core:current-presentation (world) head))
+                     (sync () (xlib:display-finish-output (lime.x11::x11-backend-display backend)))
+                     (start (&optional (screens heads))
+                       (setf backend (lime.x11:start-lime :display-name display-name :heads screens :head-bar-height 0
+                                                         :install-default-keybindings-p nil :session-file path))
+                       (sync))
+                     (stop () (lime.x11:stop-backend backend) (setf backend nil))
+                     (status () (lime.x11:backend-session-status backend))
+                     (snapshot () (let ((data (lime.persistence:snapshot-world (world))))
+                                    (remf data :revision) data))
+                     (crash ()
+                       ;; Deliberately do not remap hidden clients or save a new
+                       ;; snapshot, like losing only the WM process, not X.
+                       (lime.x11::%stop-session-persistence backend nil)
+                       (xlib:close-display (lime.x11::x11-backend-display backend) :abort t)
+                       (setf (lime.x11::x11-backend-display backend) nil backend nil))
+                     (pump-for (seconds)
+                       (let ((end (+ (get-internal-real-time) (* seconds internal-time-units-per-second))))
+                         (lime.x11:run-event-loop backend :timeout 0.01
+                          :before-event (lambda (b) (when (>= (get-internal-real-time) end)
+                                                     (setf (lime.x11::x11-backend-running-p b) nil)))))))
+              (start)
+              (check (not (getf (status) :blocked-p)) "fresh store enabled")
+              (lime.x11:backend-start-activity backend "work" "Work 日本語")
+              (dolist (window windows)
+                (xlib:display-finish-output clients)
+                (push (lime.x11:manage-window backend (xlib::lookup-window (lime.x11::x11-backend-display backend)
+                                                                         (xlib:window-id window))) ids))
+              (setf ids (nreverse ids))
+              (lime.x11:backend-hide-client backend (third ids))
+              (lime.x11:backend-hide-client backend (fourth ids))
+              (lime.core:toggle-client-floating (world) (lime.core:presentation-id (current "left")) (second ids))
+              (lime.core:set-client-tile-weight (world) (lime.core:presentation-id (current "left")) (first ids) 3/2)
+              (lime.x11:backend-save-view backend "code" "Code")
+              (lime.x11:backend-activate-view backend "code")
+              (lime.core:create-view (world) "docs" "work" "Docs"
+                                    (mapcar (lambda (id) (lime.core:make-placement :client-id id))
+                                            (list (third ids) (first ids)))
+                                    :layout-mode :monocle :focus-client-id (third ids))
+              (lime.x11:backend-extend-activity-to-head backend "work" "right")
+              (lime.x11:backend-activate-view-partially backend "docs" :head-id "right")
+              (lime.x11:backend-save-viewset backend "desk" "Desk")
+              (lime.x11:backend-set-client-floating-geometry backend (second ids) :head-id "left"
+                                                            :x 1/4 :y 1/3 :width 1/2 :height 1/2)
+              (lime.x11:backend-focus-client backend (third ids) :head-id "right")
+              (sync)
+              (setf saved (snapshot))
+              (lime.x11:backend-save-session backend)
+              (check (probe-file path) "explicit save creates file")
+              (check (= 1 (getf (status) :completed)) "explicit save waits for durable write")
+              (check (eq :unmapped (xlib:window-map-state (fourth windows))) "hidden client really unmapped")
+              (stop)
+              (check (every (lambda (w) (eq :viewable (xlib:window-map-state w))) windows) "graceful stop remaps clients")
+              (start)
+              (check (= 4 (getf (getf (status) :restore) :matched)) "all surviving clients reconnected")
+              (check (equalp saved (snapshot)) "whole desk roundtrips exactly except revision")
+              (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "focused Head restored")
+              (check (equal (list (first ids)) (lime.core:presentation-unavailable-client-ids (current "right")))
+                     "partial view stays partial, no stolen lease")
+              (check (eq :unmapped (xlib:window-map-state (fourth windows))) "hidden client re-hidden after graceful restart")
+              (check (lime.core:validate-world (world)) "restored world valid")
+              ;; Save-on-exit is not the only persistence path.
+              (lime.x11:backend-start-activity backend "game" "Game" :head-id "right")
+              (pump-for 1.0)
+              (check (>= (getf (status) :completed) 1) "autosave runs without explicit save")
+              (let ((last (getf (status) :submitted)))
+                (pump-for 0.2)
+                (check (= last (getf (status) :submitted)) "unchanged state does not rewrite disk"))
+              (setf saved (snapshot))
+              (crash)
+              (start)
+              (check (equalp saved (snapshot)) "autosaved drafts survive abrupt connection loss")
+              (check (= 4 (getf (getf (status) :restore) :matched)) "unmapped clients found after abrupt loss")
+              (check (null (gethash (xlib:window-id (fourth windows)) (lime.x11::x11-backend-pending-unmaps backend)))
+                     "already-hidden restored client has no ghost unmap token")
+              (check (equal "game" (lime.core:presentation-activity-id (current "right"))) "unsaved Activity draft persisted")
+              ;; Missing output suspends rather than losing/moving that draft.
+              (stop)
+              (start (list (first heads)))
+              (check (equal '("left") (lime.x11:backend-head-ids backend)) "new topology respected")
+              (check (find-if (lambda (p) (and (equal "game" (lime.core:presentation-activity-id p))
+                                              (null (lime.core:presentation-head-id p))))
+                             (loop for p being the hash-values of (lime.core::world-presentations (world)) collect p))
+                     "missing Head draft suspended")
+              (check (lime.core:find-viewset (world) "desk") "Viewset survives missing output")
+              (check (lime.core:validate-world (world)) "topology-restored world valid")
+              ;; A write error cannot replace the good file or kill the WM.
+              (let ((bytes (uiop:read-file-string path)) (original (symbol-function 'lime.persistence::%sync-path)))
+                (unwind-protect
+                     (progn
+                       (setf (symbol-function 'lime.persistence::%sync-path)
+                             (lambda (p) (declare (ignore p)) (error "Injected disk failure")))
+                       (check (handler-case (progn (lime.x11:backend-save-session backend) nil) (error () t))
+                              "explicit save reports disk failure"))
+                  (setf (symbol-function 'lime.persistence::%sync-path) original))
+                (check (string= bytes (uiop:read-file-string path)) "failed write leaves previous file intact")
+                (check (getf (status) :write-error) "write failure inspectable")
+                (setf (lime.x11::session-persistence-last-attempt (lime.x11::x11-backend-session-persistence backend))
+                      (- (/ (get-internal-real-time) internal-time-units-per-second) 6))
+                (pump-for 0.1)
+                (check (null (getf (status) :write-error)) "autosave retries after disk-error backoff")
+                (lime.x11:backend-save-session backend)
+                (check (null (getf (status) :write-error)) "explicit retry recovers"))
+              (stop)
+              ;; Matching XID alone is not enough, even on the same server.
+              (xlib:change-property (first windows) :_LIME_SESSION_CLIENT '(98 97 100) :STRING 8)
+              (xlib:display-finish-output clients)
+              (start (list (first heads)))
+              (check (member (first ids) (getf (getf (status) :restore) :missing) :test #'equal)
+                     "reused/mismatched identity not reconnected")
+              (check (not (find (first ids) (lime.core:view-placements (lime.core:find-view (world) "code"))
+                               :key #'lime.core:placement-client-id :test #'equal))
+                     "unverified client not smuggled into old checkpoint")
+              (stop)
+              (xlib:destroy-window (second windows))
+              (xlib:display-finish-output clients)
+              (start (list (first heads)))
+              (check (member (second ids) (getf (getf (status) :restore) :missing) :test #'equal) "dead client retired safely")
+              (check (lime.core:find-view (world) "code") "empty named checkpoint retained")
+              (stop)
+              ;; Equivalent identity boundary to a fresh X server after logout.
+              (xlib:delete-property root :_LIME_SESSION_SERVER)
+              (xlib:display-finish-output clients)
+              (start (list (first heads)))
+              (check (not (getf (getf (status) :restore) :same-server-p)) "server epoch change detected")
+              (check (zerop (getf (getf (status) :restore) :matched)) "no stale-window reconnection across servers")
+              (check (lime.core:find-activity (world) "game") "named Activities survive different X session")
+              (check (lime.core:find-view (world) "docs") "named Views survive different X session")
+              (stop)
+              (let ((bad "(:format :lime-session :version 999)"))
+                (with-open-file (out path :direction :output :if-exists :supersede) (write-string bad out))
+                (start)
+                (check (getf (status) :blocked-p) "bad file blocks autosave, not WM startup")
+                (check (getf (status) :restore-error) "restore error inspectable")
+                (check (handler-case (progn (lime.x11:backend-save-session backend) nil) (error () t))
+                       "explicit save needs authorization to replace rejected file")
+                (pump-for 1.0)
+                (stop)
+                (check (string= bad (uiop:read-file-string path)) "bad file not overwritten on autosave/exit")
+                (start)
+                (lime.x11:backend-save-session backend :replace-invalid-p t)
+                (check (not (getf (status) :blocked-p)) "explicit replacement re-enables persistence")
+                (stop))
+              ;; Exercise the actual developer restart path, not just adapter calls.
+              (let ((session (lime.dev:start-development-session :display-name display-name :heads heads
+                                                                 :session-file path :start-repl-p nil :diagnostic-file nil)))
+                (unwind-protect
+                     (progn
+                       (lime.dev:with-development-backend (b session)
+                         (lime.x11:backend-start-activity b "developer" "Developer")
+                         (check (eq :success (xlib:grab-keyboard (lime.x11::x11-backend-root b)))
+                                "install input grab before failed restart"))
+                       (let ((original (symbol-function 'lime.persistence::%sync-path)))
+                         (unwind-protect
+                              (progn
+                                (setf (symbol-function 'lime.persistence::%sync-path)
+                                      (lambda (p) (declare (ignore p)) (error "Injected pre-restart disk failure")))
+                                (check (handler-case (progn (lime.dev:restart-development-session session) nil)
+                                         (error () t)) "restart refuses to discard an unsaved desk")
+                                (check (lime.x11::x11-backend-display (lime.dev:development-session-backend session))
+                                       "failed pre-restart save keeps original X connection")
+                                (check (eq :success (xlib:grab-keyboard root)) "failed restart releases old input grabs")
+                                (xlib:ungrab-keyboard clients)
+                                (xlib:display-finish-output clients))
+                           (setf (symbol-function 'lime.persistence::%sync-path) original)))
+                       (lime.dev:restart-development-session session)
+                       (lime.dev:with-development-backend (b session)
+                         (check (lime.core:find-activity (lime.x11:x11-backend-world b) "developer")
+                                "developer restart persists world")))
+                  (lime.dev:stop-development-session session)))
+              (format t "~&Live X11 persistence: ~D checks passed. Files: ~A~%" checks directory))))
+     (when backend (lime.x11:stop-backend backend :save-session-p nil))
+     (when clients (xlib:close-display clients))
+     (uiop:terminate-process server) (uiop:wait-process server)))
+ (error (c) (format *error-output* "~&Persistence smoke failed: ~A~%" c) (uiop:quit 1)))

test/x11-pointer-ui-smoke.lisp

@@ -0,0 +1,227 @@
+;;;; 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)))

test/x11-portable-activities-smoke.lisp

@@ -0,0 +1,139 @@
+;;;; Real windows, keyboard/bar navigation, geometry, and restart on OWN Xvfb.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/x11")
+(lime.config:defconfiguration portable-smoke-config (:navigation-keys))
+
+(defun run-portable-activity-smoke ()
+  (let ((server nil) (client nil) (backend nil) (checks 0))
+    (unwind-protect
+         (let* ((directory (uiop:ensure-directory-pathname
+                            (string-trim '(#\Newline)
+                                         (uiop:run-program '("mktemp" "-d" "/tmp/lime-portable-XXXXXX") :output :string))))
+                (file (merge-pathnames "session.sexp" directory)))
+           (setf server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x700x24" "-nolisten" "tcp")
+                                             :output :stream :error-output :interactive))
+           (let* ((name (format nil ":~D" (parse-integer (read-line (uiop:process-info-output server)))))
+                  (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 700 :height 700)
+                               (lime.x11:make-x11-head :head-id "right" :x 700 :y 0 :width 500 :height 700))))
+             (setf client (xlib:open-default-display name))
+             (labels ((check (truth label) (assert truth () "Portable Activities: ~A" label) (incf checks))
+                      (world () (lime.x11:x11-backend-world backend))
+                      (current (head) (lime.core:current-presentation (world) head))
+                      (start ()
+                        (setf backend (lime.x11:start-lime :display-name name :heads heads :session-file file
+                                                          :install-default-keybindings-p nil))
+                        (lime.x11:apply-lime-configuration backend portable-smoke-config))
+                      (pump ()
+                        (xlib:display-finish-output client)
+                        (let ((count 0))
+                          (lime.x11:run-event-loop backend :timeout 0.005
+                           :before-event
+                           (lambda (b)
+                             (assert (< (incf count) 600) () "Event queue did not settle.")
+                             (xlib:display-finish-output (lime.x11::x11-backend-display b))
+                             (unless (xlib:event-listen (lime.x11::x11-backend-display b))
+                               (setf (lime.x11::x11-backend-running-p b) nil))))))
+                      (spawn ()
+                        (let ((window (xlib:create-window :parent (xlib:screen-root (xlib:display-default-screen client))
+                                                         :x 0 :y 0 :width 150 :height 100)))
+                          (xlib:map-window window) (pump)
+                          (lime.x11::%backend-client-id backend window)))
+                      (window (id) (gethash id (lime.x11::x11-backend-client-windows backend)))
+                      (visible (id) (eq :viewable (xlib:window-map-state (window id))))
+                      (tap-activity (head activity)
+                        (lime.x11:backend-select-head backend head)
+                        (let* ((display (lime.x11::x11-backend-display backend))
+                               (super (first (nth-value 6 (xlib:modifier-mapping display))))
+                               (slot (lime.x11:backend-activity-slot backend activity))
+                               (code (xlib:keysym->keycodes display (+ (char-code #\0) slot))))
+                          (xlib/xtest:fake-key-event client super t)
+                          (xlib/xtest:fake-key-event client code t)
+                          (xlib/xtest:fake-key-event client code nil)
+                          (xlib/xtest:fake-key-event client super nil) (pump)))
+                      (click-activity (head activity)
+                        (let* ((bar (gethash head (lime.x11::x11-backend-head-bars backend)))
+                               (entries (lime.x11::%bar-activity-entries backend head))
+                               (index (position activity entries :key (lambda (e) (getf e :id)) :test #'equal))
+                               (region (nth (1+ index) (lime.x11::x11-head-bar-hit-regions bar)))
+                               (bar-window (lime.x11::x11-head-bar-window bar)))
+                          (xlib/xtest:fake-motion-event client
+                            (+ (xlib:drawable-x bar-window)
+                               (floor (+ (lime.x11::x11-head-bar-hit-region-left region)
+                                         (lime.x11::x11-head-bar-hit-region-right region)) 2)) 10)
+                          (pump) (xlib/xtest:fake-button-event client 1 t)
+                          (xlib/xtest:fake-button-event client 1 nil) (pump))))
+               (start)
+               (lime.x11:backend-start-activity backend "work" "Work" :head-id "left")
+               (let ((browser (spawn)) (work (current "left")))
+                 (lime.x11:backend-select-head backend "right")
+                 (lime.x11:backend-start-activity backend "chat" "Chat")
+                 (let* ((discord (spawn)) (hidden (spawn)) (chat (current "right")))
+                   (lime.x11:backend-hide-client backend hidden)
+                   (lime.x11:backend-save-named-view backend "Chat")
+                   (lime.x11:backend-toggle-client-floating backend discord)
+                   (let ((lease (lime.core:lease-for-client (world) discord))
+                         (placement (copy-tree (lime.core:placement-data (first (lime.core:presentation-placements chat))))))
+                     (tap-activity "left" "chat")
+                     (check (eq chat (current "left")) "numeric key brings original arrangement")
+                     (check (eq work (current "right")) "numeric key swaps displaced activity")
+                     (check (visible discord) "Discord stays visible")
+                     (check (visible browser) "browser stays visible")
+                     (check (not (visible hidden)) "hidden window stays hidden")
+                     (check (eq lease (lime.core:lease-for-client (world) discord)) "lease identity survives swap")
+                     (check (equal placement (lime.core:placement-data (first (lime.core:presentation-placements chat))))
+                            "normalized floating geometry survives monitor size changes")
+                     (check (< (xlib:drawable-x (window discord)) 700) "Discord is on left in X")
+                     (check (>= (xlib:drawable-x (window browser)) 700) "browser is on right in X")
+                     (check (= (xlib:window-id (window discord)) (xlib:window-id (xlib:input-focus client)))
+                            "keyboard focus is on incoming window")
+                     (click-activity "right" "chat")
+                     (check (eq chat (current "right")) "bar click uses same portable behavior")
+                     (check (eq work (current "left")) "bar click swaps back")
+                     (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "clicked monitor retains command focus")
+                     (check (null (lime.x11::x11-backend-ui-session backend)) "no unnecessary collision menu")
+                     (dotimes (i 12)
+                       (tap-activity (if (evenp i) "left" "right") "chat")
+                       (check (lime.core:validate-world (world)) "repeated swaps preserve model")))
+                   (lime.x11:backend-select-head backend "right")
+                   (lime.x11:backend-start-activity backend "other" "Other")
+                   (let ((other (current "right")))
+                     (tap-activity "left" "chat")
+                     (check (eq other (current "right")) "inactive return leaves other monitor alone")
+                     (check (eq chat (current "left")) "inactive arrangement follows target monitor"))
+                   (lime.x11:backend-extend-activity-to-head backend "chat" "right")
+                   (check (eq chat (current "left")) "extension leaves original portion alone")
+                   (check (null (lime.core:presentation-client-ids (current "right"))) "new portion does not gather windows")
+                   (check (eq :extended (lime.x11:backend-activity-navigation-mode backend "chat")) "explicit extended mode")
+                   (tap-activity "right" "other") (tap-activity "right" "chat")
+                   (check (null (lime.core:presentation-client-ids (current "right"))) "extended empty portion intentionally resumes")
+                   (check (eq chat (current "left")) "extended returns do not pull the other portion")
+                   (tap-activity "right" "other")
+                   (lime.x11:backend-select-head backend "left")
+                   (lime.x11:backend-make-activity-portable backend "chat" "left")
+                   (check (eq :portable (lime.x11:backend-activity-navigation-mode backend "chat")) "explicit return to portability")
+                   (check (not (visible hidden)) "fold does not show hidden window")
+                   ;; Leave an intentionally empty extended activity for restart.
+                   (lime.x11:backend-extend-activity-to-head backend "other" "right")
+                   (lime.x11:backend-save-session backend)
+                   (let ((before (lime.x11::%session-snapshot backend)))
+                     (check (= 3 (getf before :version)) "versioned footprint persistence")
+                     (check (lime.x11::%validate-session-envelope before) "saved envelope validates"))
+                   (lime.x11:stop-backend backend) (setf backend nil)
+                   (start) (pump)
+                   (check (not (getf (lime.x11:backend-session-status backend) :blocked-p)) "restart restore succeeds")
+                   (check (eq :portable (lime.x11:backend-activity-navigation-mode backend "chat")) "portable state survives restart")
+                   (check (eq :extended (lime.x11:backend-activity-navigation-mode backend "other")) "empty extended intent survives restart")
+                   (check (not (visible hidden)) "hidden window remains hidden after restart")
+                   (tap-activity "right" "chat")
+                   (check (equal "chat" (lime.core:presentation-activity-id (current "right"))) "portable key works after restart")
+                   (check (visible discord) "surviving application reconnected and moved")
+                   (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors")
+                   (check (lime.core:validate-world (world)) "final invariants")
+                   (format t "~&Portable Activities smoke: ~D checks passed.~%" checks))))))
+      (when backend (ignore-errors (lime.x11:stop-backend backend)))
+      (when client (ignore-errors (xlib:close-display client :abort t)))
+      (when server (uiop:terminate-process server) (uiop:wait-process server)))))
+
+(handler-case (run-portable-activity-smoke)
+  (error (c) (format *error-output* "~&Portable Activities smoke failed: ~A~%" c) (uiop:quit 1)))

test/x11-resilience-smoke.lisp

@@ -0,0 +1,301 @@
+;;;; Fault injection against an owned Xvfb and a real supervised developer loop.
+;;;; Does not connect to the user's DISPLAY, REPL, or application processes.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/dev")
+
+(handler-case
+ (let* ((directory (uiop:ensure-directory-pathname
+                   (string-trim '(#\Newline) (uiop:run-program '("mktemp" "-d" "/tmp/lime-resilience-XXXXXX")
+                                                             :output :string))))
+       (log-path (merge-pathnames "fault.log" directory))
+       (server (uiop:launch-program
+                '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp")
+                :output :stream :error-output :interactive))
+       (session nil) (supervisor nil) (client-display nil) (checks 0)
+       (supervisor-error nil)
+       (original-configure (symbol-function 'lime.x11::%handle-configure-request))
+       (original-adopt (symbol-function 'lime.x11::icccm-adopt-client))
+       (original-shutdown-bars (symbol-function 'lime.x11::shutdown-head-bars))
+       (cleanup-count 0)
+       (original-start (symbol-function 'lime.x11:start-lime)))
+  (unwind-protect
+       (let* ((number (parse-integer (read-line (uiop:process-info-output server))))
+              (display-name (format nil ":~D" number))
+              (port-socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t))
+              (port (usocket:get-local-port port-socket)))
+         (usocket:socket-close port-socket)
+         (setf client-display (xlib:open-default-display display-name))
+         (let* ((root (xlib:screen-root (xlib:display-default-screen client-display)))
+                (windows (loop repeat 2 collect (xlib:create-window :parent root :x 0 :y 0
+                                                                    :width 100 :height 100)))
+                (original-world nil) (view-id "keep-this"))
+           (labels ((check (truth label)
+                      (assert truth () "Resilience: ~A" label) (incf checks))
+                    (await (predicate label)
+                      (loop repeat 500 when (funcall predicate) return t
+                            do (sleep 0.01)
+                            finally
+                            (error "Timed out: ~A (supervisor: ~A; running: ~S; paused: ~S; event: ~S; fault: ~S)"
+                                           label supervisor-error
+                                           (and session (lime.dev::development-session-running-p session))
+                                           (and session (paused))
+                                           (and session (lime.x11::x11-backend-event-context
+                                                         (lime.dev:development-session-backend session)))
+                                           (and session (lime.dev::development-session-event-loop-condition session)))))
+                    (owner (function)
+                      (lime.dev:call-in-development-session function :session session))
+                    (paused () (lime.dev::development-session-paused-p session))
+                    (status () (lime.dev:development-status session))
+                    (repl-alive ()
+                      (let ((socket (usocket:socket-connect "127.0.0.1" port :timeout 1)))
+                        (usocket:socket-close socket) t))
+                    (client-exists (window)
+                      (find (xlib:window-id window) (xlib:query-tree root) :key #'xlib:window-id))
+                    (new-window ()
+                      (let ((window (xlib:create-window :parent root :x 0 :y 0 :width 80 :height 80)))
+                        (xlib:display-finish-output client-display) window))
+                    (request-configure ()
+                      (setf (xlib:drawable-width (first windows)) 321)
+                      (xlib:display-finish-output client-display))
+                    (inject-failure ()
+                      (setf (symbol-function 'lime.x11::%handle-configure-request)
+                            (lambda (&rest args) (declare (ignore args))
+                              (error "Injected configure failure")))
+                      (request-configure)
+                      (await #'paused "fault pauses event handling")))
+             (dolist (window windows) (xlib:map-window window))
+             (xlib:display-finish-output client-display)
+             (setf supervisor
+                   (bt:make-thread
+                    (lambda ()
+                      (handler-case
+                          (lime.dev:run-development-session
+                           :display-name display-name :head-discovery :none :session-file nil
+                           :event-timeout 0.01 :diagnostic-file log-path :repl-port port)
+                        (error (condition) (setf supervisor-error condition))))
+                    :name "Owned resilience supervisor"))
+             (await (lambda () lime.dev:*development-session*) "session startup")
+             (setf session lime.dev:*development-session*)
+             ;; Slynk installs debugger hooks; batch test failures must still
+             ;; exit nonzero rather than falling into an EOF-driven REPL.
+             #+sbcl (sb-ext:disable-debugger)
+             (check (repl-alive) "private Slynk endpoint available")
+             (owner (lambda (backend)
+                      (setf original-world (lime.x11:x11-backend-world backend))
+                      (lime.x11:backend-save-view backend view-id "Keep this")
+                      (lime.x11:backend-activate-view backend view-id)))
+             ;; BadWindow may arrive BEFORE DestroyNotify has retired the client.
+             (let ((window (new-window)))
+               (owner (lambda (backend)
+                        (let* ((display (lime.x11::x11-backend-display backend))
+                               (managed (xlib::lookup-window display (xlib:window-id window))))
+                          (lime.x11:manage-window backend managed)
+                          (xlib:display-finish-output display)
+                          (xlib:destroy-window window)
+                          (xlib:display-finish-output client-display)
+                          (setf (xlib:drawable-x managed) 17)
+                          (xlib:display-finish-output display))))
+               (check (not (paused)) "async destroyed-client configure is harmless"))
+             ;; A query on a vanished, unregistered client must unwind, not hang.
+             (let ((window (new-window)))
+               (xlib:destroy-window window)
+               (xlib:display-finish-output client-display)
+               (let ((before (lime.x11::x11-backend-expected-x-error-count
+                              (lime.dev:development-session-backend session))))
+               (owner (lambda (backend)
+                        (let ((display (lime.x11::x11-backend-display backend)))
+                          (xlib:queue-event display :map-request :append-p t
+                                            :parent (lime.x11::x11-backend-root backend)
+                                            :window (xlib::lookup-window display (xlib:window-id window))))))
+               (await (lambda () (> (lime.x11::x11-backend-expected-x-error-count
+                                     (lime.dev:development-session-backend session)) before))
+                      "stale MapRequest processed"))
+               (check (not (paused)) "stale MapRequest survives synchronous BadWindow"))
+             ;; Mid-adoption death: registered in the adapter, not yet in the core.
+             (let ((window (new-window)) (destroyed-p nil))
+               (setf (symbol-function 'lime.x11::icccm-adopt-client)
+                     (lambda (backend client-id managed)
+                       (when (= (xlib:window-id managed) (xlib:window-id window))
+                         (xlib:destroy-window window)
+                         (xlib:display-finish-output client-display)
+                         (setf destroyed-p t))
+                       (funcall original-adopt backend client-id managed)))
+               (xlib:map-window window)
+               (xlib:display-finish-output client-display)
+               ;; Do not concurrently query the client connection while the
+               ;; injected owner-thread hook is using that same CLX display.
+               (await (lambda () destroyed-p) "adoption victim gone")
+               (owner (lambda (backend)
+                        (check (lime.core:validate-world (lime.x11:x11-backend-world backend))
+                               "partial adoption does not corrupt core")))
+               (setf (symbol-function 'lime.x11::icccm-adopt-client) original-adopt)
+               (check (not (paused)) "mid-adoption death is harmless"))
+             ;; Focus of an existing but unmapped window produces real BadMatch.
+             (let ((window (new-window)))
+               (owner (lambda (backend)
+                        (let ((display (lime.x11::x11-backend-display backend)))
+                          (xlib:set-input-focus display (xlib::lookup-window display (xlib:window-id window))
+                                                :pointer-root)
+                          (xlib:display-finish-output display))))
+               (xlib:destroy-window window)
+               (xlib:display-finish-output client-display)
+               (check (not (paused)) "unviewable focus is harmless"))
+             (check (>= (getf (getf (getf (status) :backend-status) :diagnostics) :expected-x-errors) 4)
+                    "expected races are counted")
+             ;; Root ownership conflicts must remain fatal to the attempted WM.
+             (check (handler-case
+                        (progn (lime.x11:start-backend :display-name display-name :head-discovery :none) nil)
+                      (xlib:access-error () t))
+                    "second WM cannot silently claim root")
+             (check (not (paused)) "original WM unaffected by second WM")
+             ;; Leave active grabs installed, then fail a real event handler.
+             (owner (lambda (backend)
+                      (let ((wm-root (lime.x11::x11-backend-root backend)))
+                        (check (eq :success (xlib:grab-keyboard wm-root)) "test keyboard grab")
+                        (check (eq :success (xlib:grab-pointer wm-root '(:button-press :button-release)))
+                               "test pointer grab")
+                        (xlib:display-finish-output (lime.x11::x11-backend-display backend)))))
+             (inject-failure)
+             (let* ((snapshot (status))
+                    (report (getf snapshot :last-error-report)))
+               (check (getf snapshot :running-p) "control session remains running")
+               (check (getf snapshot :event-thread-alive-p) "owner thread services paused mailbox")
+               (check (eq :configure-request (getf (getf report :event) :kind)) "diagnostic has event context")
+               (check (search "Injected configure failure" (getf report :message)) "diagnostic has original failure")
+               (check (search "%DISPATCH-NEXT-EVENT" (getf report :backtrace)) "backtrace captured before unwind")
+               (check (probe-file log-path) "fault diagnostic written")
+               (check (search "Injected configure failure" (uiop:read-file-string log-path)) "fault survives in log")
+               (check (string= "600" (string-trim '(#\Newline)
+                                                 (uiop:run-program (list "stat" "-c" "%a" (namestring log-path))
+                                                                   :output :string))) "log is private")
+               (check (bt:thread-alive-p supervisor) "supervisor did not exit after event fault")
+               (check (repl-alive) "Slynk still accepts connections"))
+             (check (eq :success (xlib:grab-keyboard root)) "fault released keyboard grab")
+             (xlib:ungrab-keyboard client-display)
+             (check (eq :success (xlib:grab-pointer root '(:button-press))) "fault released pointer grab")
+             (xlib:ungrab-pointer client-display)
+             (xlib:display-finish-output client-display)
+             (check (every #'client-exists windows) "application windows survive pause")
+             ;; Deliberately invalid model: recovery must refuse, not reset it.
+             (let ((presentation nil) (old-focus nil))
+               (owner (lambda (backend)
+                        (setf presentation (lime.core:current-presentation
+                                            (lime.x11:x11-backend-world backend)
+                                            (lime.x11:x11-backend-focused-head-id backend))
+                              old-focus (lime.core:presentation-focus-client-id presentation)
+                              (lime.core:presentation-focus-client-id presentation) "missing-client")))
+               (check (handler-case (progn (lime.dev:resume-development-session session) nil)
+                        (error () t)) "invalid model blocks resume")
+               (check (paused) "failed resume stays paused")
+               (owner (lambda (backend) (declare (ignore backend))
+                        (setf (lime.core:presentation-focus-client-id presentation) old-focus))))
+             ;; A core-valid but partially lost adapter mapping is not safe either.
+             (let ((id nil) (managed nil))
+               (owner (lambda (backend)
+                        (setf id (lime.x11::%backend-client-id backend (first windows))
+                              managed (gethash id (lime.x11::x11-backend-client-windows backend)))
+                        (remhash id (lime.x11::x11-backend-client-windows backend))))
+               (check (handler-case (progn (lime.dev:resume-development-session session) nil)
+                        (error () t)) "inconsistent adapter registration blocks resume")
+               (check (paused) "adapter validation failure stays paused")
+               (owner (lambda (backend)
+                        (setf (gethash id (lime.x11::x11-backend-client-windows backend)) managed))))
+             (setf (symbol-function 'lime.x11::%handle-configure-request) original-configure)
+             (lime.dev:resume-development-session session)
+             (check (not (paused)) "explicit resume succeeds after repair")
+             (owner (lambda (backend)
+                      (check (eq original-world (lime.x11:x11-backend-world backend)) "resume keeps same world")
+                      (check (lime.core:find-view original-world view-id) "resume keeps saved checkpoint")
+                      (check (lime.core:validate-world original-world) "resumed world valid")))
+             ;; A surviving client whose adoption was interrupted can be finished
+             ;; deliberately on resume, without replaying unrelated events.
+             (let ((window (new-window)))
+               (setf (symbol-function 'lime.x11::icccm-adopt-client)
+                     (lambda (backend id managed)
+                       (funcall original-adopt backend id managed)
+                       (when (= (xlib:window-id managed) (xlib:window-id window))
+                         (error "Injected partial adoption failure"))))
+               (xlib:map-window window)
+               (xlib:display-finish-output client-display)
+               (await #'paused "interrupted live adoption pauses")
+               (setf (symbol-function 'lime.x11::icccm-adopt-client) original-adopt)
+               (lime.dev:resume-development-session session)
+               (owner (lambda (backend)
+                        (check (lime.core:find-client original-world
+                                                      (lime.x11::%backend-client-id backend window))
+                               "resume finishes the interrupted adoption")
+                        (check (lime.x11::%validate-client-registrations backend)
+                               "repaired adoption has consistent registrations")))
+               (xlib:destroy-window window)
+               (xlib:display-finish-output client-display)
+               (await (lambda () (owner (lambda (backend)
+                                          (null (lime.x11::%backend-client-id backend window)))))
+                      "recovered client retires normally"))
+             ;; Logging itself must never cause the session to exit.
+             (owner (lambda (backend) (declare (ignore backend))
+                      (setf (lime.dev::development-session-diagnostic-file session)
+                            (merge-pathnames "fault.log/impossible" directory))))
+             (inject-failure)
+             (check (getf (status) :diagnostic-write-error) "log write failure remains inspectable")
+             (check (repl-alive) "failed log write does not take down control server")
+             (setf (symbol-function 'lime.x11::%handle-configure-request) original-configure)
+             (owner (lambda (backend) (declare (ignore backend))
+                      (setf (lime.dev::development-session-diagnostic-file session) log-path)))
+             (lime.dev:resume-development-session session)
+             ;; A slow failing restart lasts longer than the xinit supervisor poll.
+             (setf (symbol-function 'lime.x11:start-lime)
+                   (lambda (&rest args) (declare (ignore args))
+                     (sleep 1.2) (error "Injected restart failure")))
+             (check (handler-case (progn (lime.dev:restart-development-session session) nil)
+                      (error () t)) "restart failure is reported to caller")
+             (check (bt:thread-alive-p supervisor) "slow failed restart retains xinit supervisor")
+             (check (paused) "failed restart leaves paused control session")
+             (check (repl-alive) "failed restart retains same Slynk endpoint")
+             (check (every #'client-exists windows) "applications survive failed restart")
+             (setf (symbol-function 'lime.x11:start-lime) original-start)
+             (lime.dev:restart-development-session session)
+             (check (not (paused)) "explicit retry can restart")
+             (check (repl-alive) "successful restart retains Slynk")
+             (owner (lambda (backend)
+                      (check (not (eq original-world (lime.x11:x11-backend-world backend)))
+                             "restart honestly makes a new world")
+                      (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend)))
+                             "restart readopts surviving clients")))
+             ;; A deliberate quit still exits the supervisor, even while paused.
+             (inject-failure)
+             ;; A failed UI cleanup must not skip client restoration or CLX close.
+             (setf (symbol-function 'lime.x11::shutdown-head-bars)
+                   (lambda (backend) (declare (ignore backend))
+                     (incf cleanup-count)
+                     ;; Let the supervisor notice quit while a second caller
+                     ;; is already stopping. Cleanup must not run concurrently.
+                     (sleep 1.2)
+                     (error "Injected bar cleanup failure")))
+             (owner #'lime.x11:backend-request-quit)
+             (lime.dev:stop-development-session session)
+             (await (lambda () (not (bt:thread-alive-p supervisor))) "intentional quit exits supervisor")
+             (bt:join-thread supervisor)
+             (check (null supervisor-error) "supervisor returned normally")
+             (check (null lime.dev:*development-session*) "intentional quit clears current session")
+             (check (every #'client-exists windows) "graceful stop did not destroy client windows")
+             (check (= 1 cleanup-count) "concurrent explicit/supervised stop cleans up only once")
+             (check (null (lime.x11::x11-backend-display (lime.dev:development-session-backend session)))
+                    "failed bar cleanup still closes CLX")
+             (check (find :cleanup (getf (lime.x11:backend-diagnostics
+                                          (lime.dev:development-session-backend session)) :reports)
+                          :key (lambda (report) (getf report :source)))
+                    "cleanup failure retained in diagnostics")
+             (format t "~&Live X11 resilience: ~D checks passed. Diagnostics: ~A~%" checks directory))))
+    (setf (symbol-function 'lime.x11::%handle-configure-request) original-configure
+          (symbol-function 'lime.x11::icccm-adopt-client) original-adopt
+          (symbol-function 'lime.x11::shutdown-head-bars) original-shutdown-bars
+          (symbol-function 'lime.x11:start-lime) original-start)
+    (when lime.dev:*development-session* (lime.dev:stop-development-session))
+    (when supervisor (bt:join-thread supervisor))
+    (when client-display (xlib:close-display client-display))
+    (uiop:terminate-process server)
+    (uiop:wait-process server)))
+ (error (condition)
+   (format *error-output* "~&Resilience smoke failed: ~A~%" condition)
+   (uiop:quit 1)))

test/x11-session-settings-smoke.lisp

@@ -0,0 +1,177 @@
+;;;; Real XSETTINGS clients, Xresources, configuration rollback, and ownership.
+;;;; Own Xvfb only; requires Python 3 with PyGObject/GTK 3 for the client probe.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/x11")
+
+(defun run-cursor-session-smoke ()
+  (let ((server nil) (probe nil) (client nil) (backend nil) (checks 0))
+    (unwind-protect
+         (progn
+           (setf server (uiop:launch-program
+                         '("Xvfb" "-displayfd" "1" "-screen" "0" "800x600x24"
+                           "-screen" "1" "640x480x24" "-nolisten" "tcp")
+                         :output :stream :error-output :interactive))
+           (let* ((number (parse-integer (read-line (uiop:process-info-output server))))
+                  (name (format nil ":~D" number))
+                  (original (format nil "! Keep my resources~%Xft.dpi: 96~%Xcursor.theme: Adwaita~%Xcursor.size: 20~%Other.value: original~%"))
+                  (config (lime.x11:make-lime-configuration
+                           :cursor (lime.x11:make-ui-cursor-style :theme "Bibata-Original-Ice" :size 24)))
+                  (environment-theme (uiop:getenv "XCURSOR_THEME"))
+                  (environment-size (uiop:getenv "XCURSOR_SIZE")))
+             (setf client (xlib:open-default-display name))
+             (let* ((root (xlib:screen-root (xlib:display-default-screen client)))
+                    (other-root (xlib:screen-root (second (xlib:display-roots client))))
+                    (baseline nil))
+               (labels ((check (truth label)
+                          (assert truth () "Cursor session: ~A" label) (incf checks))
+                        (sync () (xlib:display-finish-output client))
+                        (resources () (lime.x11::%read-session-resources root))
+                        (owner () (xlib:selection-owner client :_XSETTINGS_S0))
+                        (state () (gethash backend lime.x11::*cursor-session-settings*))
+                        (start-probe ()
+                          (setf probe (uiop:launch-program
+                                       (list "env" "GDK_BACKEND=x11" "GTK_USE_PORTAL=0"
+                                             (format nil "DISPLAY=~A" name)
+                                             "python3" "test/gtk-cursor-probe.py")
+                                       :input :stream :output :stream :error-output :interactive))
+                          (uiop:split-string (read-line (uiop:process-info-output probe)) :separator "|"))
+                        (query ()
+                          (write-line "query" (uiop:process-info-input probe))
+                          (finish-output (uiop:process-info-input probe))
+                          (uiop:split-string (read-line (uiop:process-info-output probe)) :separator "|"))
+                        (expect-gtk (theme size)
+                          (let ((answer (loop repeat 50 for answer = (query)
+                                              when (and (equal theme (first answer))
+                                                        (equal (princ-to-string size) (second answer)))
+                                                return answer)))
+                            (check answer (format nil "GTK sees ~A / ~A (now ~S)" theme size (unless answer (query))))
+                            (check (equal (cddr answer) (cddr baseline)) "GTK font/icon/application theme unchanged")))
+                        (apply-style (theme size)
+                          (let ((next (lime.x11::copy-lime-configuration config)))
+                            (setf (lime.x11:lime-configuration-cursor next)
+                                  (lime.x11:make-ui-cursor-style :theme theme :size size))
+                            (lime.x11:apply-lime-configuration backend next)))
+                        (pump ()
+                          (loop repeat 200 while (lime.x11::%dispatch-next-event backend 0))))
+                 (lime.x11::%write-session-resources root original)
+                 (sync)
+                 ;; The GTK process predates the manager: exercise MANAGER discovery.
+                 (setf baseline (start-probe))
+                 (setf backend (lime.x11:start-backend :display-name name :head-discovery :none
+                                                      :install-default-keybindings-p nil))
+                 (check (null (owner)) "no implicit settings manager with system defaults")
+                 (xlib:send-event root :client-message '(:substructure-notify)
+                                  :window root :type :_LIME_CURSOR_TEST :format 32 :data #(0 0 0 0 0))
+                 (sync)
+                 (lime.x11:apply-lime-configuration backend config)
+                 (check (xlib:event-case ((lime.x11::x11-backend-display backend) :timeout 0 :discard-p nil)
+                          (:client-message (type) (eq type :_LIME_CURSOR_TEST)))
+                        "timestamp acquisition preserves unrelated queued events")
+                 (check (owner) "manager selection acquired")
+                 (check (zerop (hash-table-count (lime.core::world-clients (lime.x11:x11-backend-world backend))))
+                        "settings window is not a managed client")
+                 (check (search "Xcursor.theme: Bibata-Original-Ice" (resources)) "theme resource")
+                 (check (search "Xcursor.size: 24" (resources)) "size resource")
+                 (check (search "Other.value: original" (resources)) "unrelated resources preserved")
+                 (check (null (xlib:get-property other-root :RESOURCE_MANAGER)) "other X screen resources untouched")
+                 (check (null (xlib:selection-owner client :_XSETTINGS_S1)) "other X screen selection untouched")
+                 (expect-gtk "Bibata-Original-Ice" 24)
+                 (check (equal "Bibata-Original-Ice|24"
+                               (string-trim '(#\Newline)
+                                (uiop:run-program
+                                 (list "env" "-u" "XCURSOR_THEME" "-u" "XCURSOR_SIZE"
+                                       (format nil "DISPLAY=~A" name) "python3" "-c"
+                                       "import ctypes as c; x=c.CDLL('libX11.so.6'); u=c.CDLL('libXcursor.so.1'); x.XOpenDisplay.restype=c.c_void_p; d=x.XOpenDisplay(None); u.XcursorGetTheme.argtypes=[c.c_void_p]; u.XcursorGetTheme.restype=c.c_char_p; u.XcursorGetDefaultSize.argtypes=[c.c_void_p]; print(u.XcursorGetTheme(d).decode()+'|'+str(u.XcursorGetDefaultSize(d))); x.XCloseDisplay.argtypes=[c.c_void_p]; x.XCloseDisplay(d)")
+                                 :output :string))) "new non-GTK Xcursor client reads session resources")
+                 (multiple-value-bind (data type format) (xlib:get-property (owner) :_XSETTINGS_SETTINGS)
+                   (check (eq type :_XSETTINGS_SETTINGS) "settings property type")
+                   (check (= format 8) "settings property format")
+                   (check (equalp (coerce data 'vector) (lime.x11::%xsettings-cursor-bytes "Bibata-Original-Ice" 24 1))
+                          "independent client reads complete initial publication"))
+                 (let ((first-owner (owner)))
+                   (apply-style "Bibata-Original-Classic" 32)
+                   (check (xlib:window-equal first-owner (owner)) "reload keeps selection window stable")
+                   (expect-gtk "Bibata-Original-Classic" 32))
+                 ;; A child sees the cursor environment; the WM process does not.
+                 (let ((output (uiop:run-program
+                                (lime.x11::%cursor-session-launch-argv
+                                 backend '("python3" "-c" "import os; print(os.environ['XCURSOR_THEME']); print(os.environ['XCURSOR_SIZE'])"))
+                                :output :string)))
+                   (check (equal output (format nil "Bibata-Original-Classic~%32~%")) "real child inherits configured cursor settings")
+                   (check (equal environment-theme (uiop:getenv "XCURSOR_THEME")) "parent theme environment unchanged")
+                   (check (equal environment-size (uiop:getenv "XCURSOR_SIZE")) "parent size environment unchanged"))
+                 ;; New settings are visible to hooks, but failing hooks roll back.
+                 (let ((bad (lime.x11::copy-lime-configuration config)) (caught nil))
+                   (setf (lime.x11:lime-configuration-startup-hooks bad)
+                         (list (lambda (backend)
+                                 (check (equal "Bibata-Original-Ice"
+                                               (lime.x11::cursor-session-settings-theme
+                                                (gethash backend lime.x11::*cursor-session-settings*)))
+                                        "startup hook sees new settings")
+                                 (error "Rollback fixture"))))
+                   (handler-case (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t)
+                     (error () (setf caught t)))
+                   (check caught "failed config reported")
+                   (expect-gtk "Bibata-Original-Classic" 32)
+                   (check (search "Xcursor.size: 32" (resources)) "failed config resources rolled back"))
+                 ;; Returning to defaults must not read Lime's own last theme.
+                 (apply-style nil nil)
+                 (check (null (owner)) "system defaults release manager")
+                 (check (equal original (resources)) "exact original resource bytes restored")
+                 ;; GTK 3 caches a removed XSETTING in GtkSettings even though
+                 ;; GDK removes it. A fresh process must use its own defaults.
+                 (uiop:terminate-process probe) (uiop:wait-process probe)
+                 (check (equal baseline (start-probe)) "new GTK client returns to its own defaults")
+                 (check (equal (getf (lime.x11:backend-cursor-report backend) :theme)
+                               (or environment-theme "Adwaita")) "NIL theme avoids publication feedback")
+                 (apply-style nil 48)
+                 (expect-gtk (first baseline) 48)
+                 (check (search "Xcursor.theme: Adwaita" (resources)) "size-only config retains original theme resource")
+                 (apply-style :core 32)
+                 (check (null (owner)) "core mode does not impose core on applications")
+                 (check (equal original (resources)) "core mode restores resources")
+                 ;; Never steal a manager started before us or taking over later.
+                 (let ((external (xlib:create-window :parent root :x -1 :y -1 :width 1 :height 1)))
+                   (unwind-protect
+                        (progn
+                          (setf (xlib:selection-owner client :_XSETTINGS_S0) external)
+                          (sync)
+                          (apply-style "Bibata-Original-Ice" 24)
+                          (check (xlib:window-equal external (owner)) "existing manager never stolen")
+                          (check (eq :external-manager (lime.x11::cursor-session-settings-manager-status (state)))
+                                 "existing manager is reported")
+                          (setf (xlib:selection-owner client :_XSETTINGS_S0) nil)
+                          (sync)
+                          (apply-style "Bibata-Original-Ice" 24)
+                          (let ((old-window (lime.x11::cursor-session-settings-window (state))))
+                            (setf (xlib:selection-owner client :_XSETTINGS_S0) external)
+                            (sync)
+                            (pump)
+                            (check (null (lime.x11::cursor-session-settings-window (state))) "SelectionClear destroys our manager")
+                            (check (xlib:window-equal external (owner)) "takeover is respected")
+                            (check (not (member (xlib:window-id old-window)
+                                                (mapcar #'xlib:window-id (xlib:query-tree root))))
+                                   "retired manager window actually destroyed")))
+                     (xlib:destroy-window external) (sync)))
+                 ;; External xrdb edits must not be lost at shutdown.
+                 (apply-style "Bibata-Original-Ice" 24)
+                 (lime.x11::%write-session-resources
+                  root (lime.x11::%replace-cursor-resource
+                        (concatenate 'string (resources) (format nil "Other.added: later~%"))
+                        "Xcursor.size" (list (format nil "Xcursor.size: 64~%"))))
+                 (sync)
+                 (lime.x11:stop-backend backend :save-session-p nil)
+                 (check (null (owner)) "shutdown releases selection")
+                 (check (search "Other.added: later" (resources)) "external unrelated edit retained")
+                 (check (search "Xcursor.size: 64" (resources)) "externally replaced cursor size retained")
+                 (check (search "Xcursor.theme: Adwaita" (resources)) "still-owned theme restored")
+                 (check (null (gethash backend lime.x11::*cursor-session-settings*)) "shutdown forgets backend state")
+                 (format t "~&Live X11 cursor session: ~D checks passed.~%" checks)))))
+      (when backend (lime.x11:stop-backend backend :save-session-p nil))
+      (when probe (uiop:terminate-process probe) (uiop:wait-process probe))
+      (when client (xlib:close-display client :abort t))
+      (when server (uiop:terminate-process server) (uiop:wait-process server)))))
+
+(handler-case (run-cursor-session-smoke)
+  (error (condition) (format *error-output* "~&Cursor session smoke failed: ~A~%" condition) (uiop:quit 1)))

test/x11-session-settings.lisp

@@ -0,0 +1,50 @@
+(in-package #:lime.x11.test)
+(in-suite lime-x11-suite)
+
+(test cursor-resource-edits-preserve-unrelated-records
+  (let* ((original (format nil "! comment~%Xft.dpi: 96~%  Xcursor.theme : Adwaita~%st.value: foo\\~%Xcursor.size: not-a-resource~%last: no newline"))
+         (next (lime.x11::%replace-cursor-resource original "Xcursor.theme"
+                                                  (list (format nil "Xcursor.theme: Bibata~%"))))
+         (state (lime.x11::make-cursor-session-settings
+                 :resources-before original :resources-last next :resources-owned-p t)))
+    (is (= 5 (length (lime.x11::%cursor-resource-records original))))
+    (is (null (lime.x11::%cursor-resource-entries original "Xcursor.size")))
+    (is (search (format nil "st.value: foo\\~%Xcursor.size: not-a-resource~%") next))
+    (is (equal original (lime.x11::%unpublished-cursor-resources state next)))
+    (let ((external (concatenate 'string next (format nil "Other.setting: changed~%"))))
+      (is (search "Other.setting: changed" (lime.x11::%unpublished-cursor-resources state external)))
+      (is (equal (lime.x11::%cursor-resource-entries original "Xcursor.theme")
+                 (lime.x11::%cursor-resource-entries
+                  (lime.x11::%unpublished-cursor-resources state external) "Xcursor.theme"))))
+    (let ((external (lime.x11::%replace-cursor-resource next "Xcursor.theme"
+                                                       (list (format nil "Xcursor.theme: Other~%")))))
+      (is (equal external (lime.x11::%unpublished-cursor-resources state external))))
+    (is (equal "" (lime.x11::%replace-cursor-resource nil "Xcursor.theme" nil)))
+    (is (null (lime.x11::%unpublished-cursor-resources
+               (lime.x11::make-cursor-session-settings :resources-before nil :resources-last next
+                                                     :resources-owned-p t) next)))))
+
+(test cursor-settings-wire-encoding
+  (let ((bytes (lime.x11::%xsettings-cursor-bytes "Ice" 24 #x12345678)))
+    (is (equalp #(0 0 0 0 120 86 52 18 2 0 0 0 1 0 19 0) (subseq bytes 0 16)))
+    (is (equalp #(71 116 107 47 67 117 114 115 111 114 84 104 101 109 101 78 97 109 101 0)
+                (subseq bytes 16 36)))
+    (is (equalp #(120 86 52 18 3 0 0 0 73 99 101 0 0 0 19 0) (subseq bytes 36 52)))
+    (is (equalp #(120 86 52 18 24 0 0 0) (subseq bytes 72 80))))
+  (is (= 12 (length (lime.x11::%xsettings-cursor-bytes nil nil 1))))
+  (is (= 48 (length (lime.x11::%xsettings-cursor-bytes "氷" nil 1))))
+  (dolist (bad (list (format nil "Ice~%Xft.dpi: 999") (format nil "Ice~C" #\Return)))
+    (signals invalid-transition
+      (lime.x11::%validate-ui-cursor-style (make-ui-cursor-style :theme bad)))))
+
+(test cursor-child-environment-is-an-argument-vector
+  (let* ((backend (lime.x11::%make-x11-backend))
+         (argv '("program" "argument with spaces" "$no-shell-expansion")))
+    (unwind-protect
+         (progn
+           (is (eq argv (lime.x11::%cursor-session-launch-argv backend argv)))
+           (setf (gethash backend lime.x11::*cursor-session-settings*)
+                 (lime.x11::make-cursor-session-settings :theme "A theme" :size 32))
+           (is (equal (append '("env" "XCURSOR_THEME=A theme" "XCURSOR_SIZE=32") argv)
+                      (lime.x11::%cursor-session-launch-argv backend argv))))
+      (remhash backend lime.x11::*cursor-session-settings*))))

test/x11-status-smoke.lisp

@@ -0,0 +1,191 @@
+;;;; Isolated X + fake MPD protocol peer. Never changes the user's audio/player.
+(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) (listener nil) (peer nil) (peer-thread nil)
+      (peer-error nil) (gate (bt:make-lock)) (signal (bt:make-condition-variable))
+      (phase 0) (allow-change nil) (requests 0))
+  (unwind-protect
+       (let* ((number (parse-integer (read-line (uiop:process-info-output server))))
+              (display-name (format nil ":~D" number)))
+         (labels ((check (truth label) (assert truth () "Status: ~A" label) (incf checks))
+                  (await (predicate &optional (seconds 3))
+                    (let ((deadline (+ (get-internal-real-time) (* seconds internal-time-units-per-second))))
+                      (loop until (funcall predicate)
+                            do (when (> (get-internal-real-time) deadline) (error "Status test timed out: ~A" peer-error))
+                               (sleep 0.005))))
+                  (cached (id)
+                    (getf (find id (lime.x11:backend-status-provider-report backend)
+                                :key (lambda (entry) (getf entry :id))) :text))
+                  (snapshot (id)
+                    (getf (find id (lime.x11:backend-status-provider-report backend)
+                                :key (lambda (entry) (getf entry :id))) :value))
+                  (pump ()
+                    (xlib:event-case ((lime.x11::x11-backend-display backend) :timeout 1 :discard-p t)
+                      (:client-message (window type)
+                        (lime.x11::%handle-status-notification backend window type) t)
+                      (otherwise () t))))
+           (setf backend (lime.x11:start-lime :display-name display-name :head-discovery :none))
+           (let ((revision (lime.core:world-revision (lime.x11:x11-backend-world backend))))
+             ;; Fake MPD retains a change occurring between snapshot and idle.
+             (setf listener (usocket:socket-listen "127.0.0.1" 0 :reuse-address t :element-type '(unsigned-byte 8)))
+             (setf peer-thread
+                   (bt:make-thread
+                    (lambda ()
+                      (handler-case
+                          (progn
+                            (setf peer (usocket:socket-accept listener :element-type '(unsigned-byte 8)))
+                            (let ((stream (usocket:socket-stream peer)))
+                              (lime.x11::%mpd-send stream "OK MPD 0.24.0")
+                              (loop for command = (lime.x11::%mpd-line stream)
+                                    do (incf requests)
+                                       (cond
+                                         ((string= command "status")
+                                          (lime.x11::%mpd-send stream (if (zerop phase) "state: play" "state: pause"))
+                                          (lime.x11::%mpd-send stream "OK"))
+                                         ((string= command "currentsong")
+                                          (lime.x11::%mpd-send stream "Title: 日本語 music")
+                                          (lime.x11::%mpd-send stream "OK"))
+                                         ((string= command "idle player playlist")
+                                          (bt:with-lock-held (gate)
+                                            (loop until allow-change do (bt:condition-wait signal gate))
+                                            (setf allow-change nil))
+                                          (incf phase)
+                                          (lime.x11::%mpd-send stream "changed: player")
+                                          (lime.x11::%mpd-send stream "OK"))
+                                         (t (error "Unexpected MPD request: ~A" command))))))
+                        (error (condition) (setf peer-error condition)))) :name "Fake MPD"))
+             (let* ((music (lime.x11:make-music-status-provider :mpd-port (usocket:get-local-port listener)))
+                    (clock (lime.x11:make-clock-status-provider))
+                    (config (lime.x11:make-lime-configuration :status-providers (list music clock)
+                                                             :status-providers-supplied-p t)))
+               (lime.x11:apply-lime-configuration backend config)
+               (await (lambda () (and (cached :music) (cached :clock))))
+               (check (string= " 日本語 music" (cached :music)) "UTF-8 native MPD initial snapshot")
+               (check (equal '(:state :playing :title "日本語 music" :source :mpd) (snapshot :music)) "MPD publishes data, not icons")
+               (check (search "" (cached :clock)) "initial clock")
+               (check (= 2 (length (lime.x11::status-runtime-workers (lime.x11::x11-backend-status-runtime backend)))) "one worker per provider, not per Head")
+               (await (lambda () (>= requests 3)))
+               (let ((count requests))
+                 (sleep 0.08)
+                 (check (= count requests) "idle causes zero repeat MPD queries"))
+               ;; Drain initial exposures and the initial coalesced publication.
+               (loop while (xlib:event-listen (lime.x11::x11-backend-display backend)) do (pump))
+               (let ((runtime (lime.x11::x11-backend-status-runtime backend)))
+                 (check (not (lime.x11::status-runtime-dirty-p runtime)) "initial notification consumed")
+                 (bt:with-lock-held (gate) (setf allow-change t) (bt:condition-notify signal))
+                 (let ((start (get-internal-real-time)))
+                   ;; This waits for an actual X event, not a polling refresh.
+                   (pump)
+                   (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 0.75)
+                          "publication wakes an idle X wait immediately"))
+                 (check (string= " 日本語 music" (cached :music)) "pause event, no user input needed")
+                 ;; Presentation changes consume the cache on the X thread;
+                 ;; there is no new query, source restart, or source mutation.
+                 (let* ((formatter (lime.x11:status-provider-formatter music))
+                        (workers (copy-list (lime.x11::status-runtime-workers runtime)))
+                        (before (snapshot :music))
+                        (count requests))
+                   (unwind-protect
+                        (progn
+                          (setf (lime.x11:status-provider-formatter music)
+                                (lambda (data)
+                                  (lime.x11:make-head-bar-segment
+                                   :text (format nil "Track: ~A" (getf data :title)) :foreground "#55aa66")))
+                          (lime.x11:apply-lime-configuration backend config)
+                          (check (string= "Track: 日本語 music" (cached :music)) "configured label replaces default icons")
+                          (check (equal before (snapshot :music)) "formatting leaves source data intact")
+                          (check (equal workers (lime.x11::status-runtime-workers runtime)) "style reload keeps existing workers")
+                          (check (= count requests) "style change does not query MPD")
+                          (let* ((bar (gethash (first (lime.x11:backend-head-ids backend))
+                                               (lime.x11::x11-backend-head-bars backend)))
+                                 (pixels (lime.x11::ui-canvas-pixels (lime.x11::x11-head-bar-canvas bar))))
+                            (check (loop for i below (array-total-size pixels)
+                                         thereis (= #x55aa66 (logand #xffffff (row-major-aref pixels i))))
+                                   "custom widget color actually painted"))
+                          (setf (lime.x11:status-provider-formatter music)
+                                (lambda (data) (declare (ignore data)) (error "broken fixture formatter")))
+                          (lime.x11::render-head-bars backend)
+                          (check (typep (lime.x11:backend-last-command-error backend) 'error) "formatter error isolated")
+                          (check (cached :clock) "other widget survives formatter failure")
+                          (check (equal before (snapshot :music)) "formatter failure preserves data")
+                          (check (every (lambda (worker) (bt:thread-alive-p (lime.x11::status-worker-thread worker))) workers)
+                                 "formatter failure does not kill workers"))
+                     (setf (lime.x11:status-provider-formatter music) formatter)
+                     (lime.x11::render-head-bars backend)))
+                 (let ((worker (find music (lime.x11::status-runtime-workers runtime)
+                                     :key #'lime.x11::status-worker-provider)))
+                   (lime.x11:status-publish worker (snapshot :music))
+                   (check (not (lime.x11::status-runtime-dirty-p runtime)) "identical data does not enqueue a redraw")
+                   (lime.x11:status-publish worker '(:state :paused :title "burst one" :source :mpd))
+                   (lime.x11:status-publish worker '(:state :paused :title "burst two" :source :mpd))
+                   (pump)
+                   (check (string= " burst two" (cached :music)) "coalesced notification paints latest value"))
+                 (check (= revision (lime.core:world-revision (lime.x11:x11-backend-world backend))) "status never changes model state")
+                 (let ((workers (copy-list (lime.x11::status-runtime-workers runtime))))
+                   (lime.x11:apply-lime-configuration backend config)
+                   (check (equal workers (lime.x11::status-runtime-workers runtime)) "same provider objects are not duplicated on reload"))
+                 ;; Failed reload must restore old providers with live workers.
+                 (handler-case
+                     (lime.x11:apply-lime-configuration
+                      backend (lime.x11:make-lime-configuration
+                               :status-providers (list (lime.x11:make-clock-status-provider :id :replacement))
+                               :status-providers-supplied-p t
+                               :startup-hooks (list (lambda (ignored) (declare (ignore ignored)) (error "test rollback"))))
+                      :run-startup-hooks-p t)
+                   (error ()))
+                 (check (eq config (lime.x11:x11-backend-configuration backend)) "configuration rolled back")
+                 (check (equal (sort (mapcar (lambda (entry) (getf entry :id)) (lime.x11:backend-status-provider-report backend))
+                                    #'string< :key #'symbol-name)
+                               '(:clock :music)) "old provider set restored")
+                 ;; Stop while the clock sleeps and MPD is blocked in idle.
+                 (let ((workers (copy-list (lime.x11::status-runtime-workers runtime)))
+                       (start (get-internal-real-time)))
+                   (lime.x11:backend-set-head-bar-status-providers backend nil)
+                   (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 4) "bounded cancellation")
+                   (check (every (lambda (worker) (not (bt:thread-alive-p (lime.x11::status-worker-thread worker)))) workers) "all removed workers joined")
+                   (check (null (lime.x11::x11-backend-status-runtime backend)) "last removal closes notifier"))))
+             ;; A failed source is isolated and retries while other widgets run.
+             (let* ((attempts 0)
+                    (failed (lime.x11:make-status-provider
+                             :id :test-retry
+                             :run (lambda (worker)
+                                    (incf attempts)
+                                    (if (= attempts 1) (error "fixture unavailable")
+                                        (progn (lime.x11:status-publish worker "reconnected")
+                                               (lime.x11:status-wait worker 60))))))
+                    (clock (lime.x11:make-clock-status-provider)))
+               (lime.x11:backend-set-head-bar-status-providers backend (list failed clock))
+               (await (lambda () (and (cached :clock) (cached :test-retry))))
+               (check (= 2 attempts) "source failure retries with backoff")
+               (check (string= "reconnected" (cached :test-retry)) "other providers survive failure"))
+             ;; A blocked subprocess is killed/reaped, not left after reload.
+             (let ((provider (lime.x11:make-status-provider
+                              :id :blocked-helper
+                              :run (lambda (worker)
+                                     (lime.x11::%call-with-status-process
+                                      worker '("sleep" "60")
+                                      (lambda (stream process) (declare (ignore process))
+                                        (lime.x11::%status-read-line stream)))))))
+               (lime.x11:backend-set-head-bar-status-providers backend (list provider))
+               (let* ((runtime (lime.x11::x11-backend-status-runtime backend))
+                      (worker (first (lime.x11::status-runtime-workers runtime))))
+                 (await (lambda () (bt:with-lock-held ((lime.x11::status-worker-lock worker))
+                                     (lime.x11::status-worker-cancel-functions worker))))
+                 (let ((start (get-internal-real-time)))
+                   (lime.x11:backend-set-head-bar-status-providers backend nil)
+                   (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 1)
+                          "blocked helper cancellation is immediate")
+                   (check (not (bt:thread-alive-p (lime.x11::status-worker-thread worker))) "helper reader joined"))))
+             (format t "~&Status live-X smoke: ~D checks passed.~%" checks))))
+    (when backend (lime.x11:stop-backend backend))
+    (bt:with-lock-held (gate) (setf allow-change t) (bt:condition-notify signal))
+    (when peer (ignore-errors (usocket:socket-shutdown peer :io)))
+    (when listener (ignore-errors (usocket:socket-close listener)))
+    (when peer-thread (bt:join-thread peer-thread))
+    (when peer (ignore-errors (usocket:socket-close peer)))
+    (uiop:terminate-process server)
+    (uiop:wait-process server)))

test/x11-status.lisp

@@ -0,0 +1,235 @@
+(in-package #:lime.x11.test)
+(in-suite lime-x11-suite)
+
+(test status-formatters
+  (is (= 60 (lime.x11::%next-minute-delay 120)))
+  (is (= 1 (lime.x11::%next-minute-delay 179)))
+  (is (< (abs (- 0.25d0 (lime.x11::%next-minute-delay 179.75d0))) 0.00001))
+  (let ((data (lime.x11::%clock-snapshot (encode-universal-time 59 7 15 30 9 2026))))
+    (is (= 15 (getf data :hour)))
+    (is (= 2026 (getf data :year)))
+    (is (string= "  Wed Sep 30, 03:07" (lime.x11:format-clock-status data)))
+    (is (string= "  Wed Sep 30, 15:07" (lime.x11:format-clock-status data :twenty-four-hour-p t))))
+  (is (string= "  Wed Sep 30, 12:00"
+               (lime.x11:format-clock-status (lime.x11::%clock-snapshot (encode-universal-time 0 0 0 30 9 2026)))))
+  (is (= 25 (lime.x11::%volume-percent "Volume: front-left: 16384 /  25% / -36.12 dB, front-right: 16384 / 25%")))
+  (is (= 150 (lime.x11::%volume-percent "mono: 98304 / 150% / 1.23 dB")))
+  (signals error (lime.x11::%volume-percent "no sink"))
+  (is (lime.x11::%volume-event-p "Event 'change' on sink #42"))
+  (is (lime.x11::%volume-event-p "Event 'change' on server #0"))
+  (is (lime.x11::%volume-event-p "Event 'remove' on card #1"))
+  (is (not (lime.x11::%volume-event-p "Event 'new' on client #9")))
+  (is (not (lime.x11::%volume-event-p "Event 'change' on sink-input #9")))
+  (is (equal '(:state :playing :title "スパイダー" :source :mpd)
+             (lime.x11::%music-snapshot "play" "スパイダー" :mpd)))
+  (is (string= " スパイダー" (lime.x11:format-music-status (lime.x11::%music-snapshot "play" "スパイダー" :mpd))))
+  (let ((data (lime.x11::%mpris-line-snapshot (format nil "Paused~Chello" #\Tab) "spotify")))
+    (is (eq :paused (getf data :state)))
+    (is (equal "spotify" (getf data :source)))
+    (is (string= " hello" (lime.x11:format-music-status data))))
+  (is (null (lime.x11::%mpris-line-snapshot "" "spotify")))
+  (let ((data (lime.x11::%music-snapshot "stop" "old track" :mpd)))
+    (is (equal "old track" (getf data :title)))
+    (is (eq :stopped (getf data :state)))
+    (is (null (lime.x11:format-music-status data))))
+  (is (string= " Untitled track" (lime.x11:format-music-status (lime.x11::%music-snapshot "play" "" :mpd))))
+  (is (string= "  25%" (lime.x11:format-volume-status '(:volume 25 :muted-p nil))))
+  (is (string= "  Muted" (lime.x11:format-volume-status '(:volume 25 :muted-p t))))
+  (is (string= "\"a\\\"b\\\\c\"" (lime.x11::%mpd-quote "a\"b\\c")))
+  (signals error (lime.x11::%mpd-quote (format nil "foo~%bar"))))
+
+(test status-icons-and-gaps-are-presentation-options
+  (let ((font (lime.x11::%open-text-font
+               (lime.x11:make-ui-font-style
+                :family "Dina, Fira Code Nerd Font, Noto Color Emoji" :size 12 :weight :bold))))
+    (unwind-protect
+         (dolist (pair '(("" "Song") ("" "スパイダー") ("" "25%")
+                         ("" "Muted") ("" "Wed Sep 30, 03:07")))
+           (destructuring-bind (icon label) pair
+             (let ((text (lime.x11::%status-icon-label icon label "  ")))
+               (is (string= text (concatenate 'string icon "  " label)))
+               (is (> (lime.x11::%text-width font text)
+                      (lime.x11::%text-width font (concatenate 'string icon " " label)))))))
+      (lime.x11::%free-text-font font)))
+  (is (string= "PLAY · My track"
+               (lime.x11:format-music-status '(:state :playing :title "My track")
+                                             :playing-icon "PLAY" :icon-gap " · ")))
+  (is (string= "Quiet" (lime.x11:format-volume-status '(:muted-p t :volume 30)
+                                                    :muted-icon nil :muted-label "Quiet"))))
+
+(test status-icon-colors-preserve-text-and-provider-behavior
+  (let* ((click (lambda (&rest ignored) (declare (ignore ignored))))
+         (provider (make-volume-status-provider
+                    :foreground "#dbc9a6" :maximum-width 100 :click-action click
+                    :formatter (lambda (data)
+                                 (format-volume-status data :icon-foreground "#76929f"))))
+         (segment (lime.x11::%format-status-segment provider '(:volume 25))))
+    (is (string= "  25%" (head-bar-segment-text segment)))
+    (is (string= "#dbc9a6" (head-bar-segment-foreground segment)))
+    (is (string= "#76929f" (head-bar-segment-prefix-foreground segment)))
+    (is (= 1 (head-bar-segment-prefix-length segment)))
+    (is (= 100 (head-bar-segment-maximum-width segment)))
+    (is (eq click (head-bar-segment-click-action segment))))
+  (dolist (segment (list (format-music-status '(:state :paused :title "スパイダー")
+                                             :paused-icon "PAUSE" :icon-foreground "#76929f")
+                         (format-volume-status '(:muted-p t) :icon-foreground "#76929f")
+                         (format-clock-status (lime.x11::%clock-snapshot (get-universal-time))
+                                              :icon-foreground "#76929f")))
+    (is (typep segment 'head-bar-segment))
+    (is (string= "#76929f" (head-bar-segment-prefix-foreground segment)))
+    (is (null (head-bar-segment-foreground segment))))
+  (is (string= "25%" (format-volume-status '(:volume 25) :icon nil :icon-foreground "#76929f")))
+  (is (null (format-music-status '(:state :stopped) :icon-foreground "#76929f")))
+  (signals invalid-transition (format-volume-status '(:volume 25) :icon-foreground "blue"))
+  (dolist (bad '(-1 99 1/2 nil))
+    (signals invalid-transition
+      (lime.x11::%validate-head-bar-segment (make-head-bar-segment :text "test" :prefix-length bad)))))
+
+(test status-provider-validation
+  (let ((provider (lime.x11:make-clock-status-provider)))
+    (is (equal (list provider) (lime.x11::%validate-status-providers (list provider))))
+    (is (lime.x11::%validate-status-providers (list provider (lambda (backend head) (declare (ignore backend head))))))
+    (signals lime.core:invalid-transition
+      (lime.x11::%validate-status-providers (list provider (lime.x11:make-clock-status-provider)))))
+  (signals lime.core:invalid-transition
+    (lime.x11::%validate-status-providers (list (lime.x11:make-status-provider :id :broken))))
+  (signals error (lime.x11:make-music-status-provider :source :unknown))
+  (signals error (lime.x11:make-music-status-provider :maximum-width 0))
+  (signals invalid-transition
+    (lime.x11::%validate-status-providers (list (lime.x11:make-clock-status-provider :formatter nil))))
+  (signals invalid-transition
+    (lime.x11::%validate-status-providers (list (lime.x11:make-volume-status-provider :foreground "red"))))
+  (is (typep (lime.x11:make-music-status-provider :source "brave" :sources '("brave")) 'lime.x11:status-provider)))
+
+(test status-data-is-snapshotted-and-formatted-only-by-the-consumer
+  (let* ((calls 0)
+         (runtime (lime.x11::make-status-runtime :closed-p t))
+         (input (list :state :playing :title (copy-seq "Original")))
+         (provider (lime.x11:make-music-status-provider
+                    :formatter (lambda (data)
+                                 (incf calls)
+                                 ;; Even a mutating formatter cannot damage the cache.
+                                 (setf (char (getf data :title) 0) #\X)
+                                 (getf data :title))))
+         (worker (lime.x11::make-status-worker :runtime runtime :provider provider)))
+    (let ((returned (lime.x11:status-publish worker input)))
+      (setf (char (getf returned :title) 0) #\Y))
+    (setf (getf input :state) :paused (char (getf input :title) 0) #\Z)
+    (is (zerop calls))
+    (is (equal '(:state :playing :title "Original") (lime.x11::%status-worker-snapshot worker)))
+    (let ((segment (lime.x11::%format-status-segment provider (lime.x11::%status-worker-snapshot worker))))
+      (is (= 1 calls))
+      (is (string= "Xriginal" (head-bar-segment-text segment)))
+      (is (equal '(:state :playing :title "Original") (lime.x11::%status-worker-snapshot worker))))
+    ;; NIL means unavailable, not a formatting callback with incomplete data.
+    (is (null (lime.x11::%format-status-segment provider nil)))
+    (is (= 1 calls))))
+
+(test status-formatters-can-return-colored-segments-or-hide-data
+  (let* ((click (lambda (backend head) (declare (ignore backend head))))
+         (provider (lime.x11:make-volume-status-provider :foreground "#aabbcc" :maximum-width 90 :click-action click))
+         (value '(:volume 25 :muted-p nil :sink "fixture")))
+    (let ((segment (lime.x11::%format-status-segment provider value)))
+      (is (eq :volume (head-bar-segment-id segment)))
+      (is (equal "#aabbcc" (lime.x11:head-bar-segment-foreground segment)))
+      (is (= 90 (head-bar-segment-maximum-width segment)))
+      (is (eq click (head-bar-segment-click-action segment))))
+    (setf (lime.x11:status-provider-formatter provider)
+          (lambda (data) (make-head-bar-segment :text (format nil "Volume ~D" (getf data :volume))
+                                               :foreground "#112233" :maximum-width 40)))
+    (let ((segment (lime.x11::%format-status-segment provider value)))
+      (is (string= "Volume 25" (head-bar-segment-text segment)))
+      (is (equal "#112233" (lime.x11:head-bar-segment-foreground segment)))
+      (is (= 40 (head-bar-segment-maximum-width segment)))
+      (is (eq click (head-bar-segment-click-action segment))))
+    (setf (lime.x11:status-provider-formatter provider) (constantly nil))
+    (is (null (lime.x11::%format-status-segment provider value)))
+    (setf (lime.x11:status-provider-formatter provider)
+          (lambda (data) (declare (ignore data)) (make-head-bar-segment :text "bad" :foreground "not a color")))
+    (signals invalid-transition (lime.x11::%format-status-segment provider value))))
+
+(test custom-status-formatting-can-show-stopped-music-and-differing-date-styles
+  (let* ((music (lime.x11:make-music-status-provider
+                 :formatter (lambda (data) (format nil "~(~A~): ~A" (getf data :state) (getf data :title)))))
+         (clock (lime.x11:make-clock-status-provider
+                 :formatter (lambda (data) (format nil "~D-~2,'0D-~2,'0D" (getf data :year)
+                                                       (getf data :month) (getf data :day))))))
+    (is (string= "stopped: Track"
+                 (head-bar-segment-text (lime.x11::%format-status-segment music
+                                        (lime.x11::%music-snapshot "stop" "Track" :mpd)))))
+    (is (string= "2026-09-30"
+                 (head-bar-segment-text (lime.x11::%format-status-segment clock
+                                        (lime.x11::%clock-snapshot (encode-universal-time 0 0 0 30 9 2026))))))))
+
+(test status-publication-and-cancellation
+  (let* ((runtime (lime.x11::make-status-runtime :closed-p t))
+         (worker (lime.x11::make-status-worker :runtime runtime)))
+    (lime.x11:status-publish worker "first")
+    (is (string= "first" (lime.x11::status-worker-value worker)))
+    (lime.x11:status-publish worker nil)
+    (is (null (lime.x11::status-worker-value worker)))
+    (lime.x11::%stop-status-worker worker)
+    (lime.x11:status-publish worker "late result")
+    (is (null (lime.x11::status-worker-value worker)))
+    (is (not (lime.x11:status-wait worker 60)))
+    (let ((cancelled nil) (ran nil))
+      (lime.x11::%call-with-status-resource worker (lambda () (setf cancelled t))
+                                           (lambda () (setf ran t)))
+      (is (eq t cancelled))
+      (is (not ran)))))
+
+(test volume-subscription-coalesces-bursts-without-polling
+  (let* ((worker (lime.x11::make-status-worker :runtime (lime.x11::make-status-runtime :closed-p t)))
+         (snapshots 0)
+         (events (format nil "Event 'new' on client #1~%Event 'change' on sink #2~%Event 'change' on sink #2~%Event 'change' on server #0~%")))
+    (signals error ; finite fixture EOF is a normal source disconnect
+      (lime.x11::%run-volume-status
+       worker
+       :subscribe (lambda (ignored argv action)
+                    (declare (ignore ignored))
+                    (is (equal '("pactl" "subscribe") argv))
+                    (with-input-from-string (stream events) (funcall action stream nil)))
+       :snapshot (lambda (ignored) (declare (ignore ignored)) (format nil "snapshot ~D" (incf snapshots)))))
+    (is (= 2 snapshots)) ; initial + one burst, not 3 events or an interval
+    (is (string= "snapshot 2" (lime.x11::status-worker-value worker)))))
+
+(test widget-width-cap-keeps-following-widgets-and-graphemes
+  (let ((font (lime.x11::%open-text-font (lime.x11:make-ui-font-style))))
+    (unwind-protect
+         (let* ((music (lime.x11:make-head-bar-segment :id :music :text "👩‍💻👩‍💻👩‍💻 a long track"
+                                                      :maximum-width 65))
+                (clock (lime.x11:make-head-bar-segment :id :clock :text "12:34"))
+                (runs (nth-value 3 (lime.x11::%fit-bar-status font (list music clock) 500)))
+                (first (first runs)))
+           (is (eq music (getf first :segment)))
+           (is (<= (getf first :width) 65))
+           (is (find (getf first :prefix)
+                       (lime.x11::text-metrics-boundaries
+                        (lime.x11::%text-metrics font (lime.x11:head-bar-segment-text music)))))
+           (is (eq clock (getf (car (last runs)) :segment))))
+      (lime.x11::%free-text-font font))))
+
+(test music-source-switching-and-command-routing
+  (let* ((provider (lime.x11:make-music-status-provider :mpd-host "localhost" :mpd-port 6601))
+         (runtime (lime.x11::make-status-runtime :closed-p t))
+         (backend (lime.x11::%make-x11-backend :status-runtime runtime :head-bar-status-providers (list provider)))
+         (old-worker nil))
+    ;; Exercise the real lifecycle with a test source, never actual playback.
+    (setf (lime.x11::status-provider-run provider)
+          (lambda (worker) (lime.x11:status-wait worker 60))
+          old-worker (lime.x11::%start-status-worker runtime provider)
+          (lime.x11::status-runtime-workers runtime) (list old-worker))
+    (unwind-protect
+         (progn
+           (is (equal '("mpc" "--host" "localhost" "--port" "6601" "prev")
+                      (lime.x11::%music-command-argv provider :previous)))
+           (is (equal "spotify" (lime.x11:backend-cycle-music-source backend)))
+           (is (not (bt:thread-alive-p (lime.x11::status-worker-thread old-worker))))
+           (is (= 1 (length (lime.x11::status-runtime-workers runtime))))
+           (is (equal '("playerctl" "--player" "spotify" "play-pause")
+                      (lime.x11::%music-command-argv provider :toggle)))
+           (is (equal '("playerctl" "--player" "spotify" "previous")
+                      (lime.x11::%music-command-argv provider :previous)))
+           (is (eq :mpd (lime.x11:backend-cycle-music-source backend)))
+           (signals error (lime.x11::%music-command-argv provider :invalid)))
+      (mapc #'lime.x11::%stop-status-worker (lime.x11::status-runtime-workers runtime)))))

test/x11-text.lisp

@@ -0,0 +1,195 @@
+(in-package #:lime.x11.test)
+(in-suite lime-x11-suite)
+
+;; Pango/Cairo measurements are headless: these tests do not open DISPLAY.
+(lime.config:defconfiguration font-config-fixture
+  (:font :family "sans-serif, monospace" :size 18 :weight :bold))
+
+(test font-configuration-is-shared-and-validated
+  (let ((font (lime-configuration-font font-config-fixture)))
+    (is (string= "sans-serif, monospace" (ui-font-style-family font)))
+    (is (= 18 (ui-font-style-size font)))
+    (is (eq :bold (ui-font-style-weight font)))
+    (is (eq font-config-fixture (lime.x11::%validate-lime-configuration font-config-fixture))))
+  (dolist (style (list (make-ui-font-style :family "  ")
+                       (make-ui-font-style :family (format nil "bad~%family"))
+                       (make-ui-font-style :size 0)
+                       (make-ui-font-style :size 97)
+                       (make-ui-font-style :size "14")
+                       (make-ui-font-style :weight :unknown)))
+    (signals invalid-transition (lime.x11::%validate-ui-font-style style)))
+  (signals error
+    (macroexpand-1 '(lime.config:defconfiguration bad-font (:font) (:font))))
+  (signals error
+    (macroexpand-1 '(lime.config:defconfiguration bad-font (:font :typo 10)))))
+
+(test shaped-text-fits-without-splitting-graphemes
+  (let ((font (lime.x11::%open-text-font (make-ui-font-style :family "sans-serif"))))
+    (unwind-protect
+         (progn
+           (is (> (lime.x11::%text-width font "WWW") (lime.x11::%text-width font "iii")))
+           (is (= 0 (lime.x11::%text-width font "")))
+           (dolist (text '("é" "👩‍💻" "🇲🇽"))
+             (is (equalp (vector 0 (length text))
+                         (lime.x11::text-metrics-boundaries (lime.x11::%text-metrics font text)))))
+           (dolist (text '("ééé café" "👩‍💻 👩‍💻 long title" "🇲🇽🇲🇽 日本語" "مرحبا بالعالم"))
+             (let* ((metrics (lime.x11::%text-metrics font text))
+                    (boundaries (lime.x11::text-metrics-boundaries metrics)))
+               ;; Check every pixel budget, not one lucky truncation boundary.
+               (is (loop for width from 0 to (lime.x11::text-metrics-width metrics)
+                         always
+                         (multiple-value-bind (fitted prefix) (lime.x11::%fit-ui-text font text width)
+                           (and (<= (lime.x11::%text-width font fitted) width)
+                                (find prefix boundaries)
+                                (string= text fitted :end1 prefix :end2 prefix)))))))
+           (dotimes (i 300) (lime.x11::%text-width font (format nil "cache ~D" i)))
+           (is (<= (hash-table-count (lime.x11::ui-text-font-metrics font)) 256)))
+      (lime.x11::%free-text-font font))
+    (is-false (lime.x11::ui-text-font-layout font))
+    (is-false (lime.x11::ui-canvas-surface (lime.x11::ui-text-font-canvas font)))
+    (lime.x11::%free-text-font font)))
+
+(test absent-font-family-falls-back-and-font-resources-replace-safely
+  (let* ((style (make-ui-font-style :family "Lime Deliberately Nonexistent Font"))
+         (font (lime.x11::%open-text-font style))
+         (new nil))
+    (unwind-protect
+         (progn
+           (is (= 0 (lime.x11::text-metrics-unknown-glyphs (lime.x11::%text-metrics font "Hello"))))
+           (is (eq font (lime.x11::%ensure-text-font font style)))
+           (signals invalid-transition
+             (lime.x11::%ensure-text-font font (make-ui-font-style :size 0)))
+           (is-true (lime.x11::ui-text-font-layout font))
+           (setf new (lime.x11::%ensure-text-font font (make-ui-font-style :size 28)))
+           (is-false (lime.x11::ui-text-font-layout font))
+           (is (> (lime.x11::%font-line-height new) 28)))
+      (lime.x11::%free-text-font font)
+      (lime.x11::%free-text-font new))))
+
+(test status-shaping-keeps-widget-boundaries-and-rtl-click-ranges
+  (let ((font (lime.x11::%open-text-font (make-ui-font-style))))
+    (unwind-protect
+         (progn
+           (multiple-value-bind (text prefix width runs)
+               (lime.x11::%fit-bar-status
+                font (list (make-head-bar-segment :text "مرحبا")
+                           (make-head-bar-segment :text "🎮")) 300)
+             (declare (ignore text prefix))
+             (is (= 3 (length runs)))
+             (is (equal '("مرحبا" " | " "🎮") (mapcar (lambda (run) (getf run :text)) runs)))
+             (is (= width (reduce #'+ runs :key (lambda (run) (getf run :width))))))
+           (let* ((text "مرحبا...")
+                  (ranges (lime.x11::%text-prefix-ranges font text 5)))
+             (is-true ranges)
+             ;; For this RTL run the logical suffix dots are visually at left.
+             (is (plusp (caar ranges)))
+             (is (every (lambda (range) (<= 0 (car range) (cdr range)
+                                            (lime.x11::%text-width font text))) ranges))))
+      (lime.x11::%free-text-font font))))
+
+(test prefix-color-rasterization-keeps-unicode-shaping-and-resets-between-fields
+  (let ((font (lime.x11::%open-text-font (make-ui-font-style)))
+        (canvas (lime.x11::%make-ui-canvas 300 28)))
+    (unwind-protect
+         (labels ((pixels ()
+                    (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface canvas))
+                    (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas)))
+                          (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas))))
+                      (loop for y below 28 append
+                            (loop for x below 300 collect
+                                  (logand #xffffff (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4))))))))
+                  (red-p (pixel) (and (plusp pixel) (zerop (logand pixel #xffff))))
+                  (gray-p (pixel) (= (ldb (byte 8 16) pixel) (ldb (byte 8 8) pixel) (ldb (byte 8 0) pixel))))
+           (dolist (text '("A title" "é 日本語" "é مرحبا"))
+             (let ((width (lime.x11::%text-width font text)) (normal nil))
+               (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000")
+               (lime.x11::%canvas-text canvas font text 0 0 300 28 "#ffffff")
+               (setf normal (pixels))
+               (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000")
+               (lime.x11::%canvas-text canvas font text 0 0 300 28 "#ffffff"
+                                      :prefix-length 1 :prefix-color "#ff0000")
+               (let ((colored (pixels)))
+                 (is (some #'red-p colored))
+                 (is (some (lambda (p) (and (plusp p) (gray-p p))) colored))
+                 ;; Foreground attributes must not move glyphs or change coverage.
+                 (is (equal (mapcar (lambda (p) (ldb (byte 8 16) p)) normal)
+                            (mapcar (lambda (p) (ldb (byte 8 16) p)) colored))))
+               (is (= width (lime.x11::%text-width font text)))
+               (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000")
+               (lime.x11::%canvas-text canvas font text 0 0 300 28 "#ffffff")
+               (is (equal normal (pixels)))))
+           ;; With no retained source characters, truncation dots stay neutral.
+           (multiple-value-bind (ignored prefix width runs)
+               (lime.x11::%fit-bar-status font (list (make-head-bar-segment :text "Long icon and label"
+                                                   :prefix-length 4 :prefix-foreground "#ff0000"))
+                                          (lime.x11::%text-width font "..."))
+             (declare (ignore ignored prefix width))
+             (let ((run (first runs)))
+               (is (= 0 (getf run :prefix)))
+               (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000")
+               (lime.x11::%canvas-text canvas font (getf run :text) 0 0 300 28 "#ffffff"
+                                      :prefix-length (getf run :prefix) :prefix-color "#ff0000")
+               (is (every #'gray-p (pixels))))))
+      (lime.x11::%free-ui-canvas canvas)
+      (lime.x11::%free-text-font font))))
+
+(test opaque-rgb-upload-respects-truecolor-masks
+  (is (= #xf800 (lime.x11::%rgb-to-visual-pixel #xff0000 #xf800 #x7e0 #x1f 16)))
+  (is (= #xffff (lime.x11::%rgb-to-visual-pixel #xffffff #xf800 #x7e0 #x1f 16)))
+  (is (= #x563412 (lime.x11::%rgb-to-visual-pixel #x123456 #xff #xff00 #xff0000 24)))
+  (is (= #x3fffffff (lime.x11::%rgb-to-visual-pixel #xffffff #x3ff00000 #xffc00 #x3ff 30)))
+  (is (= #xff123456 (lime.x11::%rgb-to-visual-pixel #x123456 #xff0000 #xff00 #xff 32))))
+
+(test measured-palette-rows-keep-selection-visible
+  (is (equal '(0 8) (multiple-value-list (lime.x11::%ui-visible-range 20 0 8))))
+  (is (equal '(5 13) (multiple-value-list (lime.x11::%ui-visible-range 20 12 8))))
+  (is (equal '(12 20) (multiple-value-list (lime.x11::%ui-visible-range 20 19 8))))
+  (is (equal '(0 2) (multiple-value-list (lime.x11::%ui-visible-range 2 1 8))))
+  (is (equal '(0 0) (multiple-value-list (lime.x11::%ui-visible-range 0 0 0)))))
+
+(defun text-test-ink-bounds (canvas)
+  "Bounds of nonblack pixels, for checking real rasterization rather than math alone."
+  (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface canvas))
+  (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas)))
+        (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas)))
+        (left (lime.x11::ui-canvas-width canvas)) (right 0)
+        (top (lime.x11::ui-canvas-height canvas)) (bottom 0))
+    (dotimes (y (lime.x11::ui-canvas-height canvas))
+      (dotimes (x (lime.x11::ui-canvas-width canvas))
+        (when (plusp (logand #xffffff (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4)))))
+          (setf left (min left x) right (max right (1+ x))
+                top (min top y) bottom (max bottom (1+ y))))))
+    (values left top right bottom)))
+
+(test bar-baseline-centers-letter-bodies-not-empty-font-leading
+  (dolist (style (list (make-ui-font-style)
+                       (make-ui-font-style :family "Dina, Fira Code Nerd Font" :size 12 :weight :bold)))
+    (let ((font (lime.x11::%open-text-font style))
+          (canvas (lime.x11::%make-ui-canvas 240 22)))
+      (unwind-protect
+           (let ((baseline (lime.x11::%font-centered-baseline font 22)))
+             (lime.x11::%canvas-rectangle canvas 0 0 240 22 "#000000")
+             (lime.x11::%canvas-text canvas font "ABCabc012" 10 0 220 22 "#ffffff" :baseline baseline)
+             (multiple-value-bind (left top right bottom) (text-test-ink-bounds canvas)
+               (is (<= 10 left right 230))
+               (is (<= (abs (- top (- 22 bottom))) 1))
+               (is (< 0 top bottom 22)))
+             ;; A descender changes ink bounds, but must not move existing letters.
+             (let ((old-pixels nil)
+                   (sample-width (lime.x11::%text-width font "ABCabc012")))
+               (labels ((sample-pixels ()
+                          (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface canvas))
+                          (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas)))
+                                (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas))))
+                            (loop for y below 22 append
+                                  (loop for x from 10 below (+ 10 sample-width) collect
+                                        (logand #xffffff (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4)))))))))
+                 (setf old-pixels (sample-pixels))
+                 (lime.x11::%canvas-rectangle canvas 0 0 240 22 "#000000")
+                 (lime.x11::%canvas-text canvas font "ABCabc012 gj" 10 0 220 22 "#ffffff" :baseline baseline)
+                 (is (equal old-pixels (sample-pixels)))))
+             ;; Fallback glyphs and other measurements don't alter the reference.
+             (lime.x11::%text-metrics font "日本語 🎮 Égj")
+             (is (= baseline (lime.x11::%font-centered-baseline font 22))))
+        (lime.x11::%free-ui-canvas canvas)
+        (lime.x11::%free-text-font font)))))

test/x11-ui-smoke.lisp

@@ -0,0 +1,169 @@
+;;;; Real-X command-map checks. Own Xvfb server, never the current DISPLAY.
+;;;; Optionally bind *UI-SMOKE-IMAGE-DIRECTORY* before loading to save PNGs.
+(require :asdf)
+(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*)))
+(asdf:load-system "lime/x11")
+(defvar *ui-smoke-image-directory* nil)
+
+(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))))
+              (config (lime.x11:make-lime-configuration
+                       :default-keybindings-p nil
+                       :font (lime.x11:make-ui-font-style
+                              :family "Dina, Fira Code Nerd Font, Noto Color Emoji" :size 12 :weight :bold)
+                       :bar-style (lime.x11:make-head-bar-style
+                                   :background "#191919" :foreground "#d8c9ad"
+                                   :focused-background "#252525" :focused-foreground "#c49a62"
+                                   :separator-color "#8c9b7a" :title-edge-color "#444444"))))
+         (setf backend (lime.x11:start-lime :display-name (format nil ":~D" number) :head-discovery :none))
+         (lime.x11:apply-lime-configuration backend config)
+         (let* ((display (lime.x11::x11-backend-display backend))
+                (world (lime.x11:x11-backend-world backend))
+                (revision (lime.core:world-revision world)))
+           (labels ((check (truth label) (assert truth () "Command menu: ~A" label) (incf checks))
+                    (session () (lime.x11::x11-backend-ui-session backend))
+                    (overlay () (lime.x11::x11-backend-ui-overlay backend))
+                    (press (key)
+                      (let* ((keysym (if (characterp key) (char-code key) key))
+                             (code (xlib:keysym->keycodes display keysym)))
+                        (check code (format nil "keycode for ~S" key))
+                        (lime.x11::%handle-ui-key-press backend code 0)
+                        (xlib:display-finish-output display)))
+                    (frame (&optional name)
+                      (let* ((overlay (overlay))
+                             (canvas (lime.x11::x11-ui-overlay-canvas overlay))
+                             (window (lime.x11::x11-ui-overlay-window overlay)))
+                        (xlib:display-finish-output display)
+                        (check (equalp (lime.x11::ui-canvas-pixels canvas)
+                                       (xlib:image-z-pixarray
+                                        (xlib:get-image window :x 0 :y 0
+                                                        :width (lime.x11::ui-canvas-width canvas)
+                                                        :height (lime.x11::ui-canvas-height canvas)
+                                                        :format :z-pixmap))) "actual painted frame")
+                        (when (and name *ui-smoke-image-directory*)
+                          (check (zerop (lime.x11::%cairo-write-png
+                                         (lime.x11::ui-canvas-surface canvas)
+                                         (namestring (merge-pathnames name *ui-smoke-image-directory*))))
+                                 "snapshot")))))
+             (lime.x11:backend-open-command-palette backend)
+             (check (eq :key-path (lime.ui:ui-session-mode (session))) "Super-y starts at the key root")
+             (check (< (lime.x11::x11-ui-overlay-height (overlay)) 200) "root is compact")
+             (frame "menu-root.png")
+             (press #\w)
+             (check (string= "Lime  ›  w Windows" (lime.x11::%ui-menu-heading (session))) "breadcrumb")
+             (frame "menu-windows.png")
+             (press #xFF08) ; Backspace
+             (check (null (lime.ui:ui-session-key-path (session))) "Backspace returns to root")
+             (press #\Space)
+             (check (eq :search (lime.ui:ui-session-mode (session))) "Space opens search")
+             (press #\v)
+             (check (string= "v" (lime.ui:ui-session-query (session))) "search types rather than navigates")
+             (frame "menu-search.png")
+             (press #xFF09) ; Tab
+             (check (eq :key-path (lime.ui:ui-session-mode (session))) "Tab returns to root")
+             (check (= revision (lime.core:world-revision world)) "browsing does not change the model")
+             (press #\v)
+             (press #\s)
+             (check (eq :prompt (lime.ui:ui-session-mode (session))) "v s is a name prompt")
+             (check (string= "Enter to confirm; Esc to cancel." (lime.ui:ui-session-status (session)))
+                    "prompt footer describes prompt keys, not menu keys")
+             (frame "menu-prompt.png")
+             (dolist (key '(#\c #\o #\d #\e #\Space #\v #\i #\e #\w)) (press key))
+             (press #xFF0D)
+             (check (not (lime.x11:backend-command-palette-open-p backend)) "successful command closes")
+             (check (getf (lime.x11:backend-status backend) :source-view-id) "checkpoint actually saved")
+             (lime.x11:backend-open-command-palette backend)
+             (press #\v)
+             (press #\o)
+             (check (eq :search (lime.ui:ui-session-mode (session))) "v o opens the View picker")
+             (check (every (lambda (candidate) (eq :view (first (lime.ui:ui-candidate-id candidate))))
+                           (lime.ui:ui-session-candidates (session))) "View picker is scoped")
+             (press #xFF09)
+             (press #\Space)
+             (check (find :quit-lime (lime.ui:ui-session-candidates (session)) :key #'lime.ui:ui-candidate-id)
+                    "global search restored after a scoped picker")
+             (press #xFF1B)
+             (check (not (lime.x11:backend-command-palette-open-p backend)) "Escape closes")
+             ;; Explicit recall restores even the last-used checkpoint. It
+             ;; is intentionally different from reselecting a numbered slot.
+             (let* ((head-id (lime.x11:x11-backend-focused-head-id backend))
+                    (p (lime.core:current-presentation world head-id))
+                    (view-id (lime.core:presentation-source-view-id p))
+                    (saved-mode (lime.core:view-layout-mode (lime.core:find-view world view-id))))
+               (lime.core:set-presentation-layout-mode world (lime.core:presentation-id p) :monocle)
+               (lime.x11:apply-active-presentation backend)
+               (lime.x11:backend-open-command-palette backend)
+               (press #\v) (press #\o)
+               (check (search "Recall view" (lime.ui:ui-candidate-label
+                                              (first (lime.ui:ui-session-candidates (session)))))
+                      "saved arrangements use recall language")
+               (press #xFF0D)
+               (check (eq saved-mode (lime.core:presentation-layout-mode p)) "explicit recall restores saved layout")
+               (check (not (lime.core:presentation-dirty-p p)) "explicit recall clears live edits")
+               ;; Direct shortcut opens a picker; opening/choosing does not
+               ;; modify a checkpoint, and Enter defaults to Cancel.
+               (lime.core:set-presentation-layout-mode world (lime.core:presentation-id p) :monocle)
+               (lime.x11:apply-active-presentation backend)
+               (let ((before (lime.persistence:snapshot-world world)))
+                 (lime.x11:backend-open-view-update-picker backend)
+                 (frame)
+                 (press #xFF0D)
+                 (check (eq :cancel (lime.ui:ui-candidate-id
+                                     (lime.ui:ui-session-selected-candidate (session)))) "replacement defaults to cancel")
+                 (frame)
+                 (press #xFF0D)
+                 (check (not (session)) "cancel closes picker")
+                 (check (equalp before (lime.persistence:snapshot-world world)) "cancel preserves checkpoint and live desk"))
+               ;; Menu update uses the same picker and named confirmation.
+               (lime.x11:backend-open-command-palette backend)
+               (press #\v) (press #\u) (press #xFF0D) (press #xFF54) (press #xFF0D)
+               (check (not (session)) "confirmed replacement closes picker")
+               (check (eq :monocle (lime.core:view-layout-mode (lime.core:find-view world view-id))) "only confirmed update replaces checkpoint")
+               ;; A configured-command wrapper must not close its own picker.
+               (lime.x11:apply-lime-configuration
+                backend (lime.x11:make-lime-configuration
+                         :default-keybindings-p nil
+                         :commands (list (lime.x11:make-lime-command
+                                          :id :update :label "Update saved view"
+                                          :action #'lime.x11:backend-open-view-update-picker))))
+               (lime.x11:backend-open-command-palette backend)
+               (press #\Space)
+               (let ((candidate (find '(:configured-command :update)
+                                      (lime.ui:ui-session-candidates (session))
+                                      :key #'lime.ui:ui-candidate-id :test #'equal)))
+                 (check candidate "configured command is available in search")
+                 (lime.x11::%perform-ui-action backend (list :candidate candidate)))
+               (check (eq :search (lime.ui:ui-session-mode (session))) "configured update enters picker without closing")
+               (press #xFF1B))
+             ;; Program launch remains the independent direct-search surface.
+             (lime.x11:backend-open-run-prompt backend)
+             (check (eq :search (lime.ui:ui-session-mode (session))) "Super-p still searches programs")
+             (check (null (lime.ui:ui-session-key-root (session))) "launcher has no command tree")
+             (press #xFF1B)
+             ;; Small Heads / large user maps page instead of dropping entries.
+             (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 "Custom command ~D" i)))))
+               (setf (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))
+               (check (<= (lime.x11::x11-ui-overlay-height (overlay)) 238) "bounded to small Head")
+               (press #xFF56) ; PageDown
+               (check (= 1 (lime.ui:ui-session-key-page (session))) "PageDown navigates grid")
+               (frame "menu-narrow.png")
+               (press #xFF55)
+               (check (= 0 (lime.ui:ui-session-key-page (session))) "PageUp navigates grid")
+               (setf (lime.ui:ui-session-key-page (session)) 999)
+               (lime.x11::%render-command-palette backend)
+               (check (< (lime.ui:ui-session-key-page (session)) 999) "last page clamps")
+               (press #xFF55)
+               (check (>= (lime.ui:ui-session-key-page (session)) 0) "paging back remains available")
+               (press #xFF1B))
+             (format t "~&Live X11 command menu: ~D checks passed.~%" checks))))
+    (when backend (lime.x11:stop-backend backend))
+    (uiop:terminate-process server)
+    (uiop:wait-process server)))