diff --git a/core/libs/quelpa.el b/core/libs/quelpa.el index 8029a45187f4..6b7788307acc 100644 --- a/core/libs/quelpa.el +++ b/core/libs/quelpa.el @@ -1,4 +1,4 @@ -;;; quelpa.el --- Emacs Lisp packages built directly from source +;;; quelpa.el --- Emacs Lisp packages built directly from source -*- lexical-binding: t; -*- ;; Copyright 2014-2021, Steckerhalter ;; Copyright 2014-2015, Vasilij Schneidermann @@ -174,6 +174,10 @@ quelpa cache." :type '(choice (const :tag "Don't upgrade" nil) (integer :tag "Days"))) +(defcustom quelpa-async-p nil + "If non-nil, quelpa operation will not block Emacs input." + :type 'boolean) + (defvar quelpa-initialized-p nil "Non-nil when quelpa has been initialized.") @@ -227,8 +231,8 @@ On error return nil." OP is taking two version list and comparing." (let ((ver (if version (version-to-list version) quelpa--min-ver)) (pkg-ver - (or (when-let ((pkg-desc (cdr (assq name package-alist))) - (pkg-ver (package-desc-version (car pkg-desc)))) + (or (when-let* ((pkg-desc (cdr (assq name package-alist))) + (pkg-ver (package-desc-version (car pkg-desc)))) pkg-ver) (alist-get name package--builtin-versions) quelpa--min-ver))) @@ -294,7 +298,7 @@ already and should not be upgraded etc)." ((or (not (equal ver-type 'elpa)) quelpa-stable-p) melpa-ver) (melpa-ver (let ((base-ver - (if-let ((info (quelpa-build--pkg-info (symbol-name name) + (if-let* ((info (quelpa-build--pkg-info (symbol-name name) files build-dir))) (aref info 3) '(0 0 0)))) @@ -326,7 +330,7 @@ already and should not be upgraded etc)." (or (funcall package-strip-rcs-id-orig (lm-header "package-version")) (funcall package-strip-rcs-id-orig (lm-header "version")) "0")))) - (concat (if-let ((desc (quelpa-get-package-desc file-path))) + (concat (if-let* ((desc (quelpa-get-package-desc file-path))) (mapconcat #'number-to-string (package-desc-version desc) ".") "0") (pcase version @@ -597,6 +601,30 @@ position." ;;; Run Process +(defun quelpa--exit-recursive-edit-debounce () + "Exit the recursive edit, but defer when it's not safe to do so." + (if (minibufferp) + (run-at-time 0.1 nil #'quelpa--exit-recursive-edit-debounce) + (ignore-errors (exit-recursive-edit)))) + +(cl-defun quelpa--run (&key name command buffer) + "Run COMMAND and return the output. +NAME and BUFFER is the same with `make-process'." + (let (proc (exit-code 0)) + (setq proc (make-process :name name :command command :buffer buffer + :file-handler t + :sentinel (lambda (proc _exit-str) + (unless (process-live-p proc) + (setq exit-code (process-exit-status proc)) + (when quelpa-async-p + (quelpa--exit-recursive-edit-debounce)))))) + (while (process-live-p proc) + (if quelpa-async-p + ;; allow the user to continue to use Emacs while waiting + (recursive-edit) + (sleep-for 0.1))) + exit-code)) + (defun quelpa-build--run-process (dir command &rest args) "In DIR run COMMAND with ARGS. If DIR is unset, try to run from `quelpa-build-dir' @@ -613,15 +641,14 @@ Output is written to the current buffer." quelpa-build-timeout-secs) command) args) - (cons command args))))) + (cons command args)))) + (exit-code 0)) (unless (file-directory-p default-directory) (error "Can't run process in non-existent directory: %s" default-directory)) - (let ((exit-code (apply 'process-file - (car argv) nil (current-buffer) t - (cdr argv)))) - (or (zerop exit-code) - (error "Command '%s' exited with non-zero status %d: %s" - argv exit-code (buffer-string)))))) + (setq exit-code (quelpa--run :name " *quelpa-run*" :command argv :buffer (current-buffer))) + (or (zerop exit-code) + (error "Command '%s' exited with non-zero status %d: %s" + argv exit-code (buffer-string))))) (defun quelpa-build--run-process-match (regexp dir prog &rest args) "Run PROG with args and return the first match for REGEXP in its output. @@ -787,7 +814,7 @@ A number as third arg means request confirmation if NEWNAME already exists." "Get the current fossil repo for DIR." (quelpa-build--run-process-match "\\(.*\\)" dir "fossil" "remote-url")) -(defun quelpa-build--checkout-fossil (name config dir) +(defun quelpa-build--checkout-fossil (_name config dir) "Check package NAME with config CONFIG out of fossil into DIR." (unless quelpa-build-stable (let ((repo (plist-get config :url))) @@ -817,7 +844,7 @@ A number as third arg means request confirmation if NEWNAME already exists." "Get the current svn repo for DIR." (quelpa-build--run-process-match "URL: \\(.*\\)" dir "svn" "info")) -(defun quelpa-build--checkout-svn (name config dir) +(defun quelpa-build--checkout-svn (_name config dir) "Check package NAME with config CONFIG out of svn into DIR." (unless quelpa-build-stable (with-current-buffer (get-buffer-create "*quelpa-build-checkout*") @@ -932,7 +959,7 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository." (repo (plist-get config :url)) (remote (or (plist-get config :remote) "origin")) (commit (or (plist-get config :commit) - (when-let ((branch (plist-get config :branch))) + (when-let* ((branch (plist-get config :branch))) (concat remote "/" branch)))) (depth (or (plist-get config :depth) quelpa-git-clone-depth)) (partial (and (or (plist-get config :partial) quelpa-git-clone-partial) @@ -964,7 +991,7 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository." (when (and depth (not (plist-get config :commit))) `("--depth" ,(int-to-string depth) "--no-single-branch")) - (when-let ((branch (plist-get config :branch))) + (when-let* ((branch (plist-get config :branch))) `("--branch" ,branch)))))) (if quelpa-build-stable (let* ((min-bound (goto-char (point-max))) @@ -988,7 +1015,7 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository." dir (or commit (concat remote "/" (quelpa-build--git-head-branch dir))) force)) (apply 'quelpa-build--run-process - dir "git" "log" "--first-parent" "-n1" "--pretty=format:'\%ci'" + dir "git" "--no-pager" "log" "--first-parent" "-n1" "--pretty=format:'\%ci'" (quelpa-build--expand-source-file-list dir config)) (quelpa-build--find-parse-time "\ \\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} \ @@ -1217,21 +1244,22 @@ Tests and sets variable `quelpa--tar-type' if not already set." (when (and (eq (quelpa--tar-type) 'gnu) (eq system-type 'windows-nt)) (setq file (replace-regexp-in-string "^\\([a-z]\\):" "/\\1" file))) - (apply 'process-file - quelpa-build-tar-executable nil - (get-buffer-create "*quelpa-build-checkout*") - nil "-cvf" - file - "--exclude=.svn" - "--exclude=CVS" - "--exclude=.git" - "--exclude=_darcs" - "--exclude=.fslckout" - "--exclude=_FOSSIL_" - "--exclude=.bzr" - "--exclude=.hg" - (append (and quelpa-build-explicit-tar-format-p (eq (quelpa--tar-type) 'gnu) '("--format=gnu")) - (or (mapcar (lambda (fn) (concat dir "/" fn)) files) (list dir))))) + + (quelpa--run :name " *quelpa-build-checkout*" + :command (append `(,quelpa-build-tar-executable + "-cvf" + ,file + "--exclude=.svn" + "--exclude=CVS" + "--exclude=.git" + "--exclude=_darcs" + "--exclude=.fslckout" + "--exclude=_FOSSIL_" + "--exclude=.bzr" + "--exclude=.hg") + (and quelpa-build-explicit-tar-format-p (eq (quelpa--tar-type) 'gnu) '("--format=gnu")) + (or (mapcar (lambda (fn) (concat dir "/" fn)) files) (list dir))) + :buffer (get-buffer-create "*quelpa-build-checkout*"))) (defun quelpa-build--find-package-commentary (file-path) "Get commentary section from FILE-PATH." @@ -1284,7 +1312,7 @@ Tests and sets variable `quelpa--tar-type' if not already set." (newline)) (defun quelpa-build--ensure-ends-here-line (file-path) - "Add a 'FILE-PATH ends here' trailing line if missing." + "Add a `FILE-PATH ends here' trailing line if missing." (save-excursion (goto-char (point-min)) (let ((trailer (concat ";;; " @@ -1309,7 +1337,7 @@ If KEEP-VERSION is set, don't override with version 0." (if keep-version (quelpa-build--package-buffer-info-vec) (quelpa-build--update-or-insert-version "0") - (cl-flet ((package-strip-rcs-id (str) "0")) + (cl-flet ((package-strip-rcs-id (_str) "0")) (quelpa-build--package-buffer-info-vec))))))) (defun quelpa-build--get-pkg-file-info (file-path) @@ -1324,7 +1352,7 @@ If KEEP-VERSION is set, don't override with version 0." (extras (let (alist) (while rest-plist (unless (memq (car rest-plist) '(:kind :archive)) - (when-let ((value (cadr rest-plist))) + (when-let* ((value (cadr rest-plist))) (push (cons (car rest-plist) (if (eq (car-safe value) 'quote) (cadr value) @@ -1400,7 +1428,6 @@ for ALLOW-EMPTY to prevent this error." t))) (nconc lst (mapcar (lambda (f) - (let ((destname))) (cons f (concat prefix (replace-regexp-in-string @@ -1748,7 +1775,6 @@ Return t in each case." (when (plist-member (cdr cache-item) :stable) (setq quelpa-stable-p (plist-get (cdr cache-item) :stable))) (when (and quelpa-stable-p - (plist-member (cdr cache-item) :stable) (not (plist-get (cdr cache-item) :stable))) (setf (cdr (last cache-item)) '(:stable t)))) @@ -1809,11 +1835,11 @@ Return non-nil if quelpa has been initialized properly." (ignore-errors (delete-directory quelpa-packages-dir t))) (defun quelpa-arg-rcp (arg) - "Given recipe or package name ARG, return an alist '(NAME . RCP). + "Given recipe or package name ARG, return an alist (NAME . RCP). If RCP cannot be found it will be set to nil" (pcase arg (`(,name) (quelpa-get-melpa-recipe name)) - (`(,name . ,_) arg) + (`(,_name . ,_) arg) (name (quelpa-get-melpa-recipe name)))) (defun quelpa-parse-plist (plist) @@ -1900,7 +1926,7 @@ Return new package version." "Delete obsoleted packages with name NAME. With NEW-VERSION, will delete obsoleted packages that are not in same version." - (when-let ((all-pkgs (alist-get name package-alist)) + (when-let* ((all-pkgs (alist-get name package-alist)) (new-pkg-version (or new-version (package-desc-version (car all-pkgs))))) (with-demoted-errors "Error deleting package: %S" @@ -1911,7 +1937,7 @@ version." (package-delete pkg-desc 'force)))) all-pkgs)) ;; Only packages with same version remained. Just pick the first one. - (when-let (all-pkgs (alist-get name package-alist)) + (when-let* ((all-pkgs (alist-get name package-alist))) (setf (cdr all-pkgs) nil)))) ;; --- public interface ------------------------------------------------------ @@ -2003,7 +2029,7 @@ given package and remove any old versions of it even if the (cache-item (quelpa-arg-rcp arg))) (quelpa-parse-plist plist) (quelpa-parse-stable cache-item) - (when-let ((ver (apply #'quelpa-package-install arg plist))) + (when-let* ((ver (apply #'quelpa-package-install arg plist))) (when quelpa-autoremove-p (quelpa--delete-obsoleted-package (car cache-item) ver)) (quelpa-update-cache cache-item))))