83 lines
4.8 KiB
Common Lisp
83 lines
4.8 KiB
Common Lisp
;;;; Function-only upgrade; never performs a transfer on the user's desk.
|
|
(in-package #:cl-user)
|
|
|
|
(defun lime-head-send-definitions ()
|
|
;; Export before reading X11 source so its inherited core symbol resolves
|
|
;; correctly in a runtime that has not loaded the new package definition.
|
|
(export 'lime.core::move-client-to-presentation :lime.core)
|
|
(let ((manifest
|
|
'((:lime.core "src/membership.lisp"
|
|
"%MOVE-CLIENT-MEMBERSHIP" "MOVE-CLIENT-TO-ACTIVITY" "MOVE-CLIENT-TO-PRESENTATION")
|
|
(:lime.x11 "src/x11/commands.lisp"
|
|
"BACKEND-TRANSFER-FOCUSED-CLIENT-TO-HEAD" "BACKEND-REHOME-CLIENT-TO-HEAD")
|
|
(:lime.x11 "src/x11/ui.lisp"
|
|
"%UI-SEND-CONTEXT-VALID-P" "%UI-REQUEST-CLIENT-SEND"
|
|
"BACKEND-SEND-FOCUSED-CLIENT-TO-HEAD" "BACKEND-SEND-FOCUSED-CLIENT-RELATIVELY"
|
|
"%UI-KEY-PATH")
|
|
(:lime.x11 "src/x11/default-bindings.lisp" "INSTALL-DEFAULT-KEYBINDINGS")))
|
|
(definitions nil))
|
|
(dolist (entry manifest)
|
|
(destructuring-bind (package file &rest names) entry
|
|
(let* ((*package* (find-package package)) (*read-eval* nil)
|
|
(symbols (mapcar (lambda (name) (intern name *package*)) names))
|
|
(found nil))
|
|
(with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/"))
|
|
(loop for form = (read in nil :eof) until (eq form :eof)
|
|
when (and (consp form) (eq (first form) 'defun) (member (second form) symbols))
|
|
do (push form found)))
|
|
(assert (= (length symbols) (length found)))
|
|
(dolist (symbol symbols) (assert (find symbol found :key #'second)))
|
|
(setf definitions (append definitions
|
|
(mapcar (lambda (symbol) (find symbol found :key #'second)) symbols))))))
|
|
definitions))
|
|
|
|
(defun lime-upgrade-live-head-send ()
|
|
(unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process."))
|
|
(lime.dev:with-development-backend (backend)
|
|
(unless (and (lime.dev::development-session-running-p lime.dev:*development-session*)
|
|
(not (lime.dev::development-session-paused-p lime.dev:*development-session*)))
|
|
(error "Lime is not running normally."))
|
|
(when (or (lime.x11::x11-backend-pointer-drag backend)
|
|
(lime.x11::x11-backend-ui-session backend))
|
|
(error "Close the menu or finish the drag before upgrading."))
|
|
(let* ((world (lime.x11:x11-backend-world backend))
|
|
(before (lime.persistence:snapshot-world world))
|
|
(command (lime.x11:find-configured-command backend 'send-window-to-next-head))
|
|
(old-detail (lime.x11:lime-command-description command))
|
|
(old-action (lime.x11:lime-command-action command))
|
|
(config (lime.x11::x11-backend-configuration backend))
|
|
(bindings (lime.x11:list-keybindings backend))
|
|
(definitions (lime-head-send-definitions))
|
|
(old-functions
|
|
(mapcar (lambda (form)
|
|
(let ((name (second form)))
|
|
(cons name (and (fboundp name) (fdefinition name)))))
|
|
definitions)))
|
|
(assert (equal "/home/adan/.config/lime/config.lisp"
|
|
(lime.x11::x11-backend-configuration-source backend)))
|
|
(handler-case
|
|
(progn
|
|
(dolist (definition definitions) (eval definition))
|
|
(export '(lime.x11::backend-rehome-client-to-head
|
|
lime.x11::backend-send-focused-client-to-head
|
|
lime.x11::backend-send-focused-client-relatively) :lime.x11)
|
|
;; Existing binding closures resolve the command by id; no key
|
|
;; regrabs, provider restarts, or session/config reload necessary.
|
|
(setf (lime.x11:lime-command-description command)
|
|
"Send to next monitor; confirm if its Activity changes"
|
|
(lime.x11:lime-command-action command)
|
|
(lambda (backend) (lime.x11::backend-send-focused-client-relatively backend :next)))
|
|
(assert (equalp before (lime.persistence:snapshot-world world)))
|
|
(assert (eq config (lime.x11::x11-backend-configuration backend)))
|
|
(assert (equal bindings (lime.x11:list-keybindings backend)))
|
|
(assert (lime.core:validate-world world))
|
|
(list :upgraded t :world-unchanged t :bindings-unchanged t
|
|
:function-count (length definitions)
|
|
:command (lime.x11:lime-command-label command)))
|
|
(error (condition)
|
|
(setf (lime.x11:lime-command-description command) old-detail
|
|
(lime.x11:lime-command-action command) old-action)
|
|
(dolist (entry old-functions)
|
|
(if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry))))
|
|
(error condition))))))
|