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