[bot] "built_in_updates" Fri Jan 17 20:58:30 UTC 2025

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 <v.schneidermann@gmail.com>
@@ -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))))