mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-01 01:41:01 -08:00
Code Issues Projects Releases Wiki Activity

Use 'elpa-packages' files for VC metadata

Browse source 
* lisp/emacs-lisp/package-vc.el (package-vc-default-backend): Add new
option.
(package-vc-archive-spec-alist): Add new variable to store the
contents of 'elpa-packages' for each archive.
(pacakge-vc-desc->spec): Add function to query package specifications.
(package-vc--read-archive-data): Add a 'package-read-archive-hook'
implementation.
(package-vc--download-and-read-archives): Add a
'package-refresh-contents-hook' implementation.
(package-vc-main-file): Remove function.
(package-vc-generate-description-file): Use package specifications.
(package-vc-unpack-1): Adapt to previous changes.
(package-vc-unpack): Adapt to previous changes.
(package-vc-sourced-packages-list): Adapt to previous changes.
(package-vc-install): Adapt to previous changes.
* lisp/emacs-lisp/package.el (package-read-archive-hook): Allow
extending 'package-read-all-archive-contents' using a hook.
(package-read-all-archive-contents): Use 'package-read-archive-hook'.
(package-refresh-contents-hook): Allow extending
'package-refresh-contents' using a hook.
(package-refresh-contents): Use 'package-refresh-contents-hook'.
This commit is contained in:
Philip Kaludercic 2022-10-18 22:34:11 +02:00
parent 65fa87329c
commit 5d60ea47f6
No known key found for this signature in database
GPG key ID: F2C3CC513DB89F66
2 changed files with 141 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

191
lisp/emacs-lisp/package-vc.el
View file

@ -42,6 +42,7 @@
(require 'lisp-mnt)
(require 'vc)
(require 'seq)
(require 'map)
(require 'xdg)
(defgroup package-vc nil
@ -94,6 +95,79 @@
:type 'directory
:version "29.1")
(defcustom package-vc-default-backend 'Git
"VC backend to use as a fallback."
:type `(choice
,@(mapcar (lambda (b) (list 'const b))
vc-handled-backends))
:version "29.1")
(defvar package-vc-archive-spec-alist nil
"List of package specifications for each archive.
The list maps package names as string to plist. Valid keys
include
`:url' (string)
The URL of the repository used to fetch the package source.
`:branch' (string)
If given, the branch to check out after cloning the directory.
`:lisp-dir' (string)
The repository-relative directory to use for loading the Lisp
sources. If not given, the value defaults to the root directory
of the repository.
`:main-file' (string)
The main file of the project, relevant to gather package
metadata. If not given, the assumed default is the package named
with \".el\" concatenated to the end.
All other values are ignored.")
(defun pacakge-vc-desc->spec (pkg-desc &optional name)
"Retrieve the package specification for PKG-DESC.
The optional argument NAME can be used to override the default
name for PKG-DESC."
(let ((spec (alist-get
(or name (package-desc-name pkg-desc))
(alist-get (intern (package-desc-archive pkg-desc))
package-vc-archive-spec-alist)
nil nil #'string=)))
spec))
(defun package-vc--read-archive-data (archive)
"Update `package-vc-archive-spec-alist' with the contents of ARCHIVE.
This function is meant to be used as a hook for
`package--read-archive-hook'."
(let* ((contents-file (expand-file-name
(format "archives/%s/elpa-packages" archive)
package-user-dir)))
(when (file-exists-p contents-file)
(with-temp-buffer
(let ((coding-system-for-read 'utf-8))
(insert-file-contents contents-file))
(setf (alist-get (intern archive) package-vc-archive-spec-alist)
(read (current-buffer)))))))
(defun package-vc--download-and-read-archives (&optional async)
"Download specifications of all `package-archives' and read them.
Populate `package-vc-archive-spec-alist' with the result.
If optional argument ASYNC is non-nil, perform the downloads
asynchronously."
(dolist (archive package-archives)
(condition-case-unless-debug nil
(package--download-one-archive archive "elpa-packages" async)
(error (message "Failed to download `%s' archive." (car archive))))))
(add-hook 'package-read-archive-hook #'package-vc--read-archive-data 20)
(add-hook 'package-refresh-contents-hook #'package-vc--download-and-read-archives 20)
(defun package-vc-commit (pkg)
"Extract the commit of a development package PKG."
(cl-assert (package-vc-p pkg))
@ -120,21 +194,6 @@
return it
finally return "0"))
(defun package-vc-main-file (pkg-desc)
"Return the main file of the package PKG-DESC.
If no file can be found that appends \".el\" to the end of the
package name, the file with the closest file name is chosen."
(let* ((default-directory (package-desc-dir pkg-desc))
(best (format "%s.el" (package-desc-name pkg-desc)))
(distance most-positive-fixnum) next-best)
(if (file-exists-p best)
(expand-file-name best)
(dolist (file (directory-files default-directory nil "\\.el\\'"))
(let ((distance* (string-distance best file)))
(when (< distance* distance)
(setq distance distance* next-best file))))
next-best)))
(defun package-vc-generate-description-file (pkg-desc pkg-file)
"Generate a package description file for PKG-DESC.
The output is written out into PKG-FILE."
@ -142,9 +201,17 @@ The output is written out into PKG-FILE."
;; Infer the subject if missing.
(unless (package-desc-summary pkg-desc)
(setf (package-desc-summary pkg-desc)
(or (and-let* ((pkg (cadr (assq name package-archive-contents))))
(or (package-desc-summary pkg-desc)
(and-let* ((pkg (cadr (assq name package-archive-contents))))
(package-desc-summary pkg))
(lm-summary (package-vc-main-file pkg-desc))
(and-let* ((pkg-spec (pacakge-vc-desc->spec pkg-desc))
(main-file (plist-get pkg-spec :main-file)))
(lm-summary main-file))
(and-let* ((main-file (expand-file-name
(format "%s.el" name)
(package-desc-dir pkg-desc)))
((file-exists-p main-file)))
(lm-summary main-file))
package--default-summary)))
(let ((print-level nil)
(print-quoted t)
@ -241,8 +308,13 @@ The output is written out into PKG-FILE."
(cons (package-desc-name pkg-desc)
package-selected-packages)))
(defun package-vc-unpack (pkg-desc)
"Install the package described by PKG-DESC."
(defun package-vc-unpack (pkg-desc pkg-spec &optional rev)
"Install the package described by PKG-DESC.
PKG-SPEC is a package specification is a property list describing
how to fetch and build the package PKG-DESC. See
`package-vc-archive-spec-alist' for details. The optional argument
REV specifies a specific revision to checkout. This overrides
the `:brach' attribute in PKG-SPEC."
(let* ((name (package-desc-name pkg-desc))
(dirname (package-desc-full-name pkg-desc))
(pkg-dir (expand-file-name dirname package-user-dir)))
@ -251,12 +323,10 @@ The output is written out into PKG-FILE."
(if (yes-or-no-p "Overwrite previous checkout?")
(package--delete-directory pkg-dir pkg-desc)
(error "There already exists a checkout for %s" name)))
(pcase-let* ((attr (package-desc-extras pkg-desc))
(`(,backend ,repo ,dir ,branch)
(or (alist-get :upstream attr)
(error "Source package has no repository")))
(pcase-let* ((extras (package-desc-extras pkg-desc))
((map :url :branch :lisp-dir) pkg-spec)
(repo-dir
(if (null dir)
(if (null lisp-dir)
pkg-dir
(unless (file-exists-p package-vc-repository-store)
(make-directory package-vc-repository-store t))
@ -265,21 +335,21 @@ The output is written out into PKG-FILE."
;; FIXME: We aren't sure this directory
;; will be unique, but we can try other
;; names to avoid an unnecessary error.
(file-name-base repo)))))
(file-name-base url)))))
;; Clone the repository into `repo-dir' if necessary
(unless (file-exists-p repo-dir)
(make-directory (file-name-directory repo-dir) t)
(unless (setf (car (alist-get :upstream attr))
(vc-clone backend repo repo-dir))
(error "Failed to clone %s from %s" name repo)))
(unless (vc-clone (or (alist-get :vc-backend extras)
package-vc-default-backend)
url repo-dir)
(error "Failed to clone %s from %s" name url)))
(unless (eq pkg-dir repo-dir)
;; Link from the right position in `repo-dir' to the package
;; directory in the ELPA store.
(make-symbolic-link (file-name-concat repo-dir dir) pkg-dir))
(when-let ((default-directory repo-dir)
(rev (or (alist-get :rev attr) branch)))
(make-symbolic-link (file-name-concat repo-dir lisp-dir) pkg-dir))
(when-let* ((default-directory repo-dir) (rev (or rev branch)))
(vc-retrieve-tag pkg-dir rev)))
(package-vc-unpack-1 pkg-desc pkg-dir)))
@ -288,17 +358,14 @@ The output is written out into PKG-FILE."
"Generate a list of packages with VC data."
(seq-filter
(lambda (pkg)
(let ((extras (package-desc-extras (cadr pkg))))
(or (alist-get :vc extras)
;; If we have no explicit VC data, we can try a kind of
;; heuristic and use the URL header, that might already be
;; pointing towards a repository, and use that as a backup
(and-let* ((url (alist-get :url extras))
(backend (alist-get url package-vc-heusitic-alist
nil nil #'string-match-p)))
(setf (alist-get :vc (package-desc-extras (cadr pkg)))
(list backend url))
t))))
(or (pacakge-vc-desc->spec (cadr pkg))
;; If we have no explicit VC data, we can try a kind of
;; heuristic and use the URL header, that might already be
;; pointing towards a repository, and use that as a backup
(and-let* ((extras (package-desc-extras (cadr pkg)))
(url (alist-get :url extras))
(backend (alist-get url package-vc-heusitic-alist
nil nil #'string-match-p))))))
package-archive-contents))
(defun package-vc-update (pkg-desc)
@ -315,7 +382,6 @@ The output is written out into PKG-FILE."
(package-vc-unpack-1 pkg-desc default-directory)))
(package-vc-unpack-1 pkg-desc default-directory))))
;;;###autoload
(defun package-vc-install (name-or-url &optional name rev)
"Fetch the source of NAME-OR-URL.
@ -337,27 +403,26 @@ be requested using REV."
(name (file-name-base input)))
(list input (intern (string-remove-prefix "emacs-" name))))))
(package--archives-initialize)
(package-vc-unpack
(cond
((and (stringp name-or-url)
(url-type (url-generic-parse-url name-or-url)))
(package-desc-create
:name (or name (intern (file-name-base name-or-url)))
:kind 'vc
:extras `((:upstream . ,(list nil name-or-url nil nil))
(:rev . ,rev))))
((when-let* ((desc (cadr (assoc name-or-url package-archive-contents
#'string=)))
(upstream (or (alist-get :vc (package-desc-extras desc))
(user-error "Package has no VC data"))))
(cond
((and-let* ((stringp name-or-url)
(backend (alist-get name-or-url
package-vc-heusitic-alist
nil nil #'string-match-p)))
(package-vc-unpack
(package-desc-create
:name (if (stringp name-or-url)
(intern name-or-url)
name-or-url)
:kind 'vc
:extras `((:upstream . ,upstream)
(:rev . ,rev)))))
((user-error "Unknown package to fetch: %s" name-or-url)))))
:name (or name (intern (file-name-base name-or-url)))
:kind 'vc)
(list :vc-backend backend :url name-or-url)
rev)))
((and-let* ((desc (assoc name-or-url package-archive-contents #'string=)))
(package-vc-unpack
(let ((copy (copy-package-desc (cadr desc))))
(setf (package-desc-kind copy) 'vc)
copy)
(or (pacakge-vc-desc->spec (cadr desc))
(user-error "Package has no VC data"))
rev)))
((user-error "Unknown package to fetch: %s" name-or-url))))
;;;###autoload
(defalias 'package-checkout #'package-vc-install)

15
lisp/emacs-lisp/package.el
View file

@ -1650,13 +1650,19 @@ This is the value of `package-archive-priorities' last time
by arbitrary functions to decide whether it is necessary to call
it again.")
(defvar package-read-archive-hook (list #'package-read-archive-contents)
"List of functions to call to read the archive contents.
Each function must take an optional argument, a symbol indicating
what archive to read in. The symbol ought to be a key in
`package-archives'.")
(defun package-read-all-archive-contents ()
"Read cached archive file for all archives in `package-archives'.
If successful, set or update `package-archive-contents'."
(setq package-archive-contents nil)
(setq package--old-archive-priorities package-archive-priorities)
(dolist (archive package-archives)
(package-read-archive-contents (car archive))))
(run-hook-with-args 'package-read-archive-hook (car archive))))
;;;; Package Initialize
@ -1832,6 +1838,11 @@ asynchronously."
(error (message "Failed to download `%s' archive."
(car archive))))))
(defvar package-refresh-contents-hook (list #'package--download-and-read-archives)
"List of functions to call to refresh the package archive.
Each function may take an optional argument indicating that the
operation ought to be executed asynchronously.")
;;;###autoload
(defun package-refresh-contents (&optional async)
"Download descriptions of all configured ELPA packages.
@ -1850,7 +1861,7 @@ downloads in the background."
(condition-case-unless-debug error
(package-import-keyring default-keyring)
(error (message "Cannot import default keyring: %S" (cdr error))))))
(package--download-and-read-archives async))
(run-hook-with-args 'package-refresh-contents-hook async))
;;; Dependency Management