emenel/doomemacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Normalize package before checks in 'doom update'

Browse source 
This reduces the likelihood that straight will throw up invisible
popups, blocking the update process indefinitely.
This commit is contained in:
Henrik Lissner 2019-08-21 18:34:55 -04:00
parent 464e7f8bbd
commit 94ba098e43
No known key found for this signature in database
GPG key ID: 5F6C0EA160557395
1 changed files with 49 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

47
core/cli/packages.el
View file

@ -148,28 +148,35 @@ a list of packages that will be installed."
(let (packages errors) (let (packages errors)
(load ,(concat doom-core-dir "core.el")) (load ,(concat doom-core-dir "core.el"))
(dolist (recipe ',group) (dolist (recipe ',group)
(straight--with-plist recipe (when (straight--repository-is-available-p recipe)
(package local-repo remote upstream-repo upstream-host) (straight-vc-git--destructure recipe
(package local-repo upstream-remote upstream-repo upstream-host)
(condition-case e (condition-case e
;; HACK There's a contingency of `straight-fetch-package' (let ((default-directory (straight--repos-dir local-repo)))
;; where it will pop up a window for confirmation, but this ;; HACK We normalize packages to avoid certain scenarios
;; window is invisible because a) this command runs in a ;; where `straight-fetch-package' will create an
;; headless session and b) this code runs in an async child ;; interactive popup prompting for action (which will
;; process, so we ensure the remotes are correctly set up to ;; cause this async process to block indefinitely). We
;; prevent that contingency. ;; can't use `straight-normalize-package' because could
(when (and local-repo (straight--repository-is-available-p recipe)) ;; create popup prompts too, so we do it manually:
(when-let* (shell-command-to-string "git merge --abort")
((url (ignore-errors (straight--get-call "git" "remote" "get-url" remote))) (straight--get-call "git" "reset" "--hard")
(desired-url (straight-vc-git--encode-url upstream-repo upstream-host))) (straight--get-call "git" "clean" "-ffd")
(unless (straight-vc-git--urls-compatible-p url desired-url) (when upstream-repo
(straight--get-call "git" "remote" "remove" remote) (let ((desired-url (straight-vc-git--encode-url upstream-repo upstream-host))
(straight--get-call "git" "remote" "add" remote desired-url) (actual-url (condition-case nil
(straight--get-call "git" "fetch" remote))) (straight--get-call "git" "remote" "get-url" upstream-remote)
(error nil))))
(unless (straight-vc-git--urls-compatible-p actual-url desired-url)
(straight--get-call "git" "remote" "remove" upstream-remote)
(straight--get-call "git" "remote" "add" upstream-remote desired-url)
(straight--get-call "git" "fetch" upstream-remote))))
(straight-fetch-package package) (straight-fetch-package package)
;; REVIEW Is there no better way to get this information? ;; REVIEW Is there no better way to get this information?
(let* ((default-directory (straight--repos-dir local-repo)) (let ((n (length
(n (string-to-number (split-string
(straight--get-call "git" "rev-list" "--right-only" "--count" "HEAD..@{u}"))) (straight--get-call "git" "rev-list" "--left-right" "HEAD..@{u}")
"\n" t)))
(pretime (pretime
(string-to-number (string-to-number
(shell-command-to-string "git log -1 --format=%at HEAD"))) (shell-command-to-string "git log -1 --format=%at HEAD")))
@ -189,7 +196,7 @@ a list of packages that will be installed."
packages)))) packages))))
(error (error
(push (list package e (string-trim (or (straight--process-get-output) ""))) (push (list package e (string-trim (or (straight--process-get-output) "")))
errors))))) errors))))))
(if errors (if errors
(cons 'error errors) (cons 'error errors)
(cons 'ok (nreverse packages)))) (cons 'ok (nreverse packages))))