Re: feature/package+vc 04c4c578c7 3/4: Allow for packages to be installed directly from VCS

[Philip Kaludercic <philipk@posteo.net>]

[-- Attachment #1: Type: text/plain, Size: 1304 bytes --]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>>>                 We're not there yet, but the above adds info which we
>>> can (and do in `elpa-admin.el`) extract from the VCS, so it's going
>>> "backward".  IOW, it's making things worse rather than better.
>>
>> You mean the addition of :release-rev, right?
>
> Yes.
>
>> Yes, it could be extracted from the VCS, but finding a generic system
>> is tricky as you have mentioned.  How about a new VC method
>> `last-change' that takes a region and returns the last revision that
>> affected it.  Any backend that supports `annotate' ought to be able to
>> determine it, right?
>
> Fine by me.  As mentioned earlier, there's a good chance that if you use
> a different VCS than Git, this method will sometimes end up selecting
> a different commit than `elpa-admin.el`, but if we insist on supporting
> a local VCS different from the one used by `elpa-admin.el`, then we
> probably have to live with that.

I guess so.  Here is a possible patch that should behave close enough to
elpa-admin.el using "blame" (an obvious exception is the missing handler
for the new :merge property, but I have been wondering if it might also
be fair to always add "--first-parent" for Git).

The default handler just wraps vc-annotate, so it is a bit more fragile.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Extract-last-source-package-release-from-local-VCS-d.patch --]
[-- Type: text/x-patch, Size: 10416 bytes --]

From 30f1e7c1e93dda496412f76f70b2f49b30407b11 Mon Sep 17 00:00:00 2001
From: Philip Kaludercic <philipk@posteo.net>
Date: Sun, 30 Oct 2022 11:43:11 +0100
Subject: [PATCH] Extract last source package release from local VCS data

* lisp/emacs-lisp/package-vc.el (package-vc-archive-spec-alist):
Unmention :release-rev
(package-vc-desc->spec): Fall back on other archives if a
specification is missing.
(package-vc-main-file): Add new function, copying the behaviour of
elpa-admin.el.
(package-vc-generate-description-file): Use 'package-vc-main-file'.
(package-vc-unpack): Handle special value ':last-release'.
(package-vc-release-rev): Add new function using 'last-change'.
(package-vc-install): Pass ':last-release' as REV instead of a
release.
* lisp/vc/vc-git.el (vc-git-last-change): Add Git 'last-change'
implementation.
* lisp/vc/vc.el (vc-default-last-change): Add default 'last-change'
implementation.

This attempts to replicate the behaviour of elpa-admin.el's
"elpaa--get-last-release-commit".
---
 lisp/emacs-lisp/package-vc.el | 88 +++++++++++++++++++++++------------
 lisp/vc/vc-git.el             | 17 +++++++
 lisp/vc/vc.el                 | 18 +++++++
 3 files changed, 94 insertions(+), 29 deletions(-)

diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
index 3816c6152d..6597989777 100644
--- a/lisp/emacs-lisp/package-vc.el
+++ b/lisp/emacs-lisp/package-vc.el
@@ -139,12 +139,6 @@ package-vc-archive-spec-alist
 metadata.  If not given, the assumed default is the package named
 with \".el\" concatenated to the end.
 
-        `:release-rev' (string)
-
-A revision string indicating the revision used for the current
-release in the package archive.  If missing or nil, no release
-was made.
-
         `:vc-backend' (symbol)
 
 A symbol indicating what the VC backend to use for cloning a
@@ -179,8 +173,10 @@ package-vc-desc->spec
 name for PKG-DESC."
   (alist-get
    (or name (package-desc-name pkg-desc))
-   (alist-get (intern (package-desc-archive pkg-desc))
-              package-vc-archive-spec-alist)
+   (if (package-desc-archive pkg-desc)
+       (alist-get (intern (package-desc-archive pkg-desc))
+                  package-vc-archive-spec-alist)
+     (mapcan #'append (mapcar #'cdr package-vc-archive-spec-alist)))
    nil nil #'string=))
 
 (define-inline package-vc-query-spec (pkg-desc prop)
@@ -258,6 +254,20 @@ package-vc-version
            return it
            finally return "0"))
 
+(defun package-vc-main-file (pkg-desc)
+  "Return the main file for PKG-DESC."
+  (cl-assert (package-vc-p pkg-desc))
+  (let ((pkg-spec (package-vc-desc->spec pkg-desc)))
+    (or (plist-get pkg-spec :main-file)
+        (expand-file-name
+         (format "%s.el" (package-desc-name pkg-desc))
+         (file-name-concat
+          (or (package-desc-dir pkg-desc)
+              (expand-file-name
+               (package-desc-name pkg-desc)
+               package-user-dir))
+          (plist-get pkg-spec :lisp-dir))))))
+
 (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."
@@ -265,18 +275,13 @@ package-vc-generate-description-file
     ;; Infer the subject if missing.
     (unless (package-desc-summary pkg-desc)
       (setf (package-desc-summary pkg-desc)
-            (or (package-desc-summary pkg-desc)
-                (and-let* ((pkg (cadr (assq name package-archive-contents))))
-                  (package-desc-summary pkg))
-                (and-let* ((pkg-spec (package-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 ((main-file (package-vc-main-file pkg-desc)))
+              (or (package-desc-summary pkg-desc)
+                  (and-let* ((pkg (cadr (assq name package-archive-contents))))
+                    (package-desc-summary pkg))
+                  (and main-file (file-exists-p main-file)
+                       (lm-summary main-file))
+                  package--default-summary))))
     (let ((print-level nil)
           (print-quoted t)
           (print-length nil))
@@ -424,9 +429,16 @@ package-vc-unpack
                                                  nil nil #'string=)
                                       :vc-backend)
                            package-vc-default-backend)))
-          (unless (vc-clone url backend repo-dir (or rev branch))
+          (unless (vc-clone url backend repo-dir
+                            (or (and (not (eq rev :last-release)) rev) branch))
             (error "Failed to clone %s from %s" name url))))
 
+      ;; Check out the latest release if requested
+      (when (eq rev :last-release)
+        (if-let ((release-rev (package-vc-release-rev pkg-desc)))
+            (vc-retrieve-tag pkg-dir release-rev)
+          (message "No release revision was found, continuing...")))
+
       (unless (eq pkg-dir repo-dir)
         ;; Link from the right position in `repo-dir' to the package
         ;; directory in the ELPA store.
@@ -466,6 +478,22 @@ package-vc--archives-initialize
   (unless package-vc-archive-data-alist
     (package-vc--download-and-read-archives)))
 
+(defun package-vc-release-rev (pkg-desc)
+  "Find the latest revision that bumps the \"Version\" tag for PKG-DESC.
+If no such revision can be found, return nil."
+  (with-current-buffer (find-file-noselect (package-vc-main-file pkg-desc))
+    (vc-buffer-sync)
+    (save-excursion
+      (goto-char (point-min))
+      (let ((case-fold-search t))
+        (when (re-search-forward (concat (lm-get-header-re "version") ".*$")
+                                 (lm-code-start) t)
+          (ignore-error vc-not-supported
+            (vc-call-backend (vc-backend (buffer-file-name))
+                             'last-change
+                             (match-beginning 0)
+                             (match-end 0))))))))
+
 ;;;###autoload
 (defun package-vc-install (name-or-url &optional name rev backend)
   "Fetch the source of NAME-OR-URL.
@@ -477,9 +505,11 @@ package-vc-install
 metadata will be consulted for the URL.  An explicit revision can
 be requested using REV.  If the command is invoked with a prefix
 argument, the revision used for the last release in the package
-archive is used.  If a NAME-OR-URL is a URL, that is to say a
-string, the VC backend used to clone the repository can be set by
-BACKEND.  If missing, `package-vc-guess-backend' will be used."
+archive is used.  This can also be reproduced by passing the
+special value `:last-release' as REV.  If a NAME-OR-URL is a URL,
+that is to say a string, the VC backend used to clone the
+repository can be set by BACKEND.  If missing,
+`package-vc-guess-backend' will be used."
   (interactive
    (progn
      ;; Initialize the package system to get the list of package
@@ -490,11 +520,7 @@ package-vc-install
                     "Fetch package source (name or URL): " packages))
             (name (file-name-base input)))
        (list input (intern (string-remove-prefix "emacs-" name))
-             (and current-prefix-arg
-                  (or (package-vc-query-spec
-                       (cadr (assoc input package-archive-contents #'string=))
-                       :release-rev)
-                      (user-error "No release revision was found")))))))
+             (and current-prefix-arg :last-release)))))
   (package-vc--archives-initialize)
   (cond
    ((and-let* ((stringp name-or-url)
@@ -511,6 +537,10 @@ package-vc-install
          (setf (package-desc-kind copy) 'vc)
          copy)
        (or (package-vc-desc->spec (cadr desc))
+           (and-let* ((extras (package-desc-extras (cadr desc)))
+                      (url (alist-get :url extras))
+                      (backend (package-vc-guess-backend url)))
+             (list :vc-backend backend :url url))
            (user-error "Package has no VC data"))
        rev)))
    ((user-error "Unknown package to fetch: %s" name-or-url))))
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 6137ce75ce..cd62effd08 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1632,6 +1632,23 @@ vc-git-annotate-extract-revision-at-line
 		    (expand-file-name fname (vc-git-root default-directory))))
 	  revision)))))
 
+(defun vc-git-last-change (from to)
+  (vc-buffer-sync)
+  (let ((file (file-relative-name
+               (buffer-file-name)
+               (vc-git-root (buffer-file-name))))
+        (start (line-number-at-pos from t))
+        (end (line-number-at-pos to t)))
+    (with-temp-buffer
+      (when (vc-git--out-ok
+             "blame" "--porcelain"
+             (format "-L%d,%d" start end)
+             file)
+        (goto-char (point-min))
+        (save-match-data
+          (when (looking-at "\\`\\([[:alnum:]]+\\)[[:space:]]+")
+            (match-string 1)))))))
+
 ;;; TAG/BRANCH SYSTEM
 
 (declare-function vc-read-revision "vc"
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 38209ef39e..c8d28c144b 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -448,6 +448,11 @@
 ;; - mergebase (rev1 &optional rev2)
 ;;
 ;;   Return the common ancestor between REV1 and REV2 revisions.
+;;
+;; - last-change (from to)
+;;
+;;   Return the most recent revision that made a change between FROM
+;;   and TO.
 
 ;; TAG/BRANCH SYSTEM
 ;;
@@ -3584,6 +3589,19 @@ vc-clone
                            remote directory rev)))
             (throw 'ok res)))))))
 
+(declare-function log-view-current-tag "log-view" (&optional pos))
+(defun vc-default-last-change (_backend from to)
+  "Default `last-change' implementation.
+FROM and TO are used as region markers"
+  (save-window-excursion
+    (let* ((buf (window-buffer (vc-region-history from to)))
+           (proc (get-buffer-process buf)))
+      (cl-assert (processp proc))
+      (while (accept-process-output proc))
+      (with-current-buffer buf
+        (prog1 (log-view-current-tag)
+          (kill-buffer))))))
+
 \f
 
 ;; These things should probably be generally available
-- 
2.38.0


[-- Attachment #3: Type: text/plain, Size: 353 bytes --]


Invoking `package-vc-install' with a prefix argument will now check out
the specific commit that bumps the version tag.  At least for git, the
slight problem here is that this means the head is in a detached state,
not connected to any specific branch.  I don't know if there is any
elegant solution to this problem, or if it should even be "solved".