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

91
core/cli/packages.el
View file

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