feature/package+vc 5d60ea47f6 6/6: Use 'elpa-packages' files for VC metadata

[Philip Kaludercic]

branch: feature/package+vc
commit 5d60ea47f6625dc7da6ceb475dc624e33deb198f
Author: Philip Kaludercic <philipk@posteo.net>
Commit: Philip Kaludercic <philipk@posteo.net>

    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'.
---
 lisp/emacs-lisp/package-vc.el | 191 ++++++++++++++++++++++++++++--------------
 lisp/emacs-lisp/package.el    |  15 +++-
 2 files changed, 141 insertions(+), 65 deletions(-)

diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
index 7098de2ece..c420c5f87a 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 245e41ee74..425abfeea5 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