Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[bot] built_in_updates #16792

Draft
wants to merge 1 commit into
base: develop
Choose a base branch
from
Draft

[bot] built_in_updates #16792

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
110 changes: 68 additions & 42 deletions core/libs/quelpa.el
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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>
Expand Down Expand Up @@ -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.")

Expand Down Expand Up @@ -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)))
Expand Down Expand Up @@ -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))))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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'
Expand All @@ -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.
Expand Down Expand Up @@ -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)))
Expand Down Expand Up @@ -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*")
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)))
Expand All @@ -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\\} \
Expand Down Expand Up @@ -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."
Expand Down Expand Up @@ -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 ";;; "
Expand All @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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))))

Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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"
Expand All @@ -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 ------------------------------------------------------
Expand Down Expand Up @@ -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))))
Expand Down
Loading