diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 8e4f2819db..e995853768 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -56,6 +56,9 @@ package-vc :group 'package :version "29.1") +(defconst package-vc-elpa-packages-version 1 + "Version number of the package specification format understood by package-vc.") + (defcustom package-vc-heuristic-alist `((,(rx bos "http" (? "s") "://" (or (: (? "www.") "github.com" @@ -144,6 +147,34 @@ package-vc-archive-spec-alist All other values are ignored.") +(defvar package-vc-archive-data-alist nil + "List of package specification archive metadata. +Each element of the list has the form (ARCHIVE . PLIST), where +PLIST keys are one of: + + `:version' (integer) + +Indicating the version of the file formatting, to be compared +with `package-vc-elpa-packages-version'. + + `:vc-backend' (symbol) + +A symbol indicating what the default VC backend to use if a +package specification does not indicate anything. The value +ought to be a member of `vc-handled-backends'. If missing, +`vc-clone' will fall back onto `package-vc-default-backend'. + +All other values are ignored.") + +(define-inline package-vc-query-archive-data (archive prop) + "Query the property PROP for the package specification for PKG-DESC. +If no package specification can be determined, the function will +return nil." + (inline-letevals (archive prop) + (inline-quote (plist-get + (alist-get ,archive package-vc-archive-data-alist) + ,prop)))) + (defun package-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 @@ -171,9 +202,23 @@ package-vc--read-archive-data (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))))))) + (insert-file-contents contents-file) + ;; The response from the server is expected to have the form + ;; + ;; ((("foo" :url "..." ...) ...) + ;; :version 1 + ;; :default-vc Git) + (let ((spec (read (current-buffer)))) + (when (= package-vc-elpa-packages-version + (plist-get (cdr spec) :version)) + (setf (alist-get (intern archive) package-vc-archive-spec-alist) + (car spec))) + (setf (alist-get (intern archive) package-vc-archive-data-alist) + (cdr spec)) + (when-let ((default-vc (plist-get (cdr spec) :default-vc)) + ((not (memq default-vc vc-handled-backends)))) + (warn "Archive `%S' expects missing VC backend %S" + archive (plist-get (cdr spec) :default-vc))))))))) (defun package-vc--download-and-read-archives (&optional async) "Download specifications of all `package-archives' and read them. @@ -374,6 +419,10 @@ package-vc-unpack (unless (file-exists-p repo-dir) (make-directory (file-name-directory repo-dir) t) (let ((backend (or (package-vc-guess-backend url) + (plist-get (alist-get (package-desc-archive pkg-desc) + package-vc-archive-data-alist + nil nil #'string=) + :vc-backend) package-vc-default-backend))) (unless (vc-clone url backend repo-dir (or rev branch)) (error "Failed to clone %s from %s" name url))))