From: Philip Kaludercic Date: Tue, 18 Oct 2022 20:34:11 +0000 (+0200) Subject: Use 'elpa-packages' files for VC metadata X-Git-Tag: emacs-29.0.90~1616^2~307^2~49 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5d60ea47f6625dc7da6ceb475dc624e33deb198f;p=emacs.git Use 'elpa-packages' files for VC metadata * 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'. --- diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 7098de2ece3..c420c5f87a7 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -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) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 245e41ee74a..425abfeea5c 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -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